From 9c5ab74e9ea5edd4b435f169d2d04cfbe0dd4a4c Mon Sep 17 00:00:00 2001 From: Puzzled-Face Date: Fri, 13 Oct 2023 09:14:45 +0000 Subject: [PATCH 1/5] Refactoring matchTolerance --- DESCRIPTION | 1 - NAMESPACE | 4 +- R/Data-class.R | 9 +- R/Data-methods.R | 4 +- R/Model-class.R | 2 +- R/Model-methods.R | 2 +- R/Rules-methods.R | 2 +- R/Simulations-methods.R | 10 +- R/checkmate.R | 90 +++- R/helpers.R | 2 +- R/mcmc.R | 2 +- _pkgdown.yaml | 2 +- design/ordinal-crm.Rmd | 4 +- design/ordinal_crm.Rmd | 4 +- man/assert_equal.Rd | 50 +++ man/check_equal.Rd | 43 ++ man/check_probabilities.Rd | 2 +- ...Tolerance.Rd => match_within_tolerance.Rd} | 6 +- ...ot-of-datada-with-placebo-and-blinding.svg | 360 ++++++++-------- .../plot-of-datada-with-placebo.svg | 408 +++++++++--------- ...-of-datadual-with-placebo-and-blinding.svg | 252 +++++------ .../plot-of-datadual-with-placebo.svg | 306 ++++++------- tests/testthat/test-checkmate.R | 22 + 23 files changed, 896 insertions(+), 691 deletions(-) create mode 100644 man/assert_equal.Rd create mode 100644 man/check_equal.Rd rename man/{matchTolerance.Rd => match_within_tolerance.Rd} (82%) diff --git a/DESCRIPTION b/DESCRIPTION index 9a666fe19..eda613f8a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -42,7 +42,6 @@ Imports: checkmate (>= 2.2.0), futile.logger, GenSA, - grid, magrittr, gridExtra, lifecycle, diff --git a/NAMESPACE b/NAMESPACE index 4a26ae6a1..b92925ca0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -270,12 +270,14 @@ export(TDsamplesDesign) export(TITELogisticLogNormal) export(ThreePlusThreeDesign) export(approximate) +export(assert_equal) export(assert_length) export(assert_probabilities) export(assert_probability) export(assert_probability_range) export(assert_range) export(biomarker) +export(check_equal) export(check_length) export(check_probabilities) export(check_probability) @@ -336,7 +338,7 @@ export(h_validate_combine_results) export(is_logging_enabled) export(log_trace) export(logit) -export(matchTolerance) +export(match_within_tolerance) export(maxDose) export(maxSize) export(mcmc) diff --git a/R/Data-class.R b/R/Data-class.R index a48c114fb..76dea483b 100644 --- a/R/Data-class.R +++ b/R/Data-class.R @@ -123,7 +123,8 @@ Data <- function(x = numeric(), assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE) assert_flag(placebo) - doseGrid <- as.numeric(sort(doseGrid)) + doseGrid <- sort(doseGrid) + assert_subset(x, doseGrid) if (length(ID) == 0 && length(x) > 0) { message("Used default patient IDs!") @@ -148,10 +149,10 @@ Data <- function(x = numeric(), y = as.integer(y), ID = as.integer(ID), cohort = as.integer(cohort), - doseGrid = doseGrid, + doseGrid = as.numeric(doseGrid), nObs = length(x), nGrid = length(doseGrid), - xLevel = matchTolerance(x = x, table = doseGrid), + xLevel = match_within_tolerance(x, doseGrid), placebo = placebo ) } @@ -488,7 +489,7 @@ DataOrdinal <- function(x = numeric(), doseGrid = doseGrid, nObs = length(x), nGrid = length(doseGrid), - xLevel = matchTolerance(x = x, table = doseGrid), + xLevel = match_within_tolerance(x = x, table = doseGrid), placebo = placebo, yCategories = yCategories ) diff --git a/R/Data-methods.R b/R/Data-methods.R index 4ea5f884b..ec43bdd8e 100644 --- a/R/Data-methods.R +++ b/R/Data-methods.R @@ -308,7 +308,7 @@ setMethod( n <- length(y) # Which grid level is the dose? - gridLevel <- matchTolerance(x, object@doseGrid) + gridLevel <- match_within_tolerance(x, object@doseGrid) object@xLevel <- c(object@xLevel, rep(gridLevel, n)) # Add dose. @@ -399,7 +399,7 @@ setMethod( n <- length(y) # Which grid level is the dose? - gridLevel <- matchTolerance(x, object@doseGrid) + gridLevel <- match_within_tolerance(x, object@doseGrid) object@xLevel <- c(object@xLevel, rep(gridLevel, n)) # Add dose. diff --git a/R/Model-class.R b/R/Model-class.R index a489cc12a..f9987e346 100644 --- a/R/Model-class.R +++ b/R/Model-class.R @@ -2591,7 +2591,7 @@ EffFlexi <- function(eff, ) x <- c(eff_dose, getEff(data, no_dlt = TRUE)$x_no_dlt) - x_level <- matchTolerance(x, data@doseGrid) + x_level <- match_within_tolerance(x, data@doseGrid) X <- model.matrix(~ -1L + factor(x_level, levels = seq_len(data@nGrid))) X <- matrix(as.integer(X), ncol = ncol(X)) # To remove some obsolete attributes. diff --git a/R/Model-methods.R b/R/Model-methods.R index 042575579..d2dfd73a6 100644 --- a/R/Model-methods.R +++ b/R/Model-methods.R @@ -1395,7 +1395,7 @@ setMethod( assert_length(dose, len = n_samples) dose_grid <- model@data@doseGrid - dose_level <- matchTolerance(dose, dose_grid) + dose_level <- match_within_tolerance(dose, dose_grid) dose[which(!is.na(dose_level))] <- dose_grid[stats::na.omit(dose_level)] # linear interpolation, NA for doses that are outside of the dose_grid range. diff --git a/R/Rules-methods.R b/R/Rules-methods.R index dd3af7367..fe660b8c3 100644 --- a/R/Rules-methods.R +++ b/R/Rules-methods.R @@ -1500,7 +1500,7 @@ setMethod( if (is.null(incrmnt)) { callNextMethod(increments, data, ...) } else { - max_dose_lev_part1 <- matchTolerance(max(data@x), data@part1Ladder) + max_dose_lev_part1 <- match_within_tolerance(max(data@x), data@part1Ladder) new_max_dose_level <- max_dose_lev_part1 + incrmnt assert_true(new_max_dose_level >= 0L) assert_true(new_max_dose_level <= length(data@part1Ladder)) diff --git a/R/Simulations-methods.R b/R/Simulations-methods.R index 71edf2cec..1e14a7280 100644 --- a/R/Simulations-methods.R +++ b/R/Simulations-methods.R @@ -470,7 +470,7 @@ setMethod("summary", doseMostSelected <- as.numeric(names(which.max(table(doseSelected)))) xMostSelected <- - matchTolerance(doseMostSelected, + match_within_tolerance(doseMostSelected, table = doseGrid ) @@ -588,7 +588,7 @@ setMethod("summary", ## dose level most often selected as MTD xMostSelected <- - matchTolerance(start@doseMostSelected, + match_within_tolerance(start@doseMostSelected, table = doseGrid ) @@ -683,7 +683,7 @@ setMethod("summary", ## dose level most often selected as MTD xMostSelected <- - matchTolerance(start@doseMostSelected, + match_within_tolerance(start@doseMostSelected, table = doseGrid ) @@ -1584,7 +1584,7 @@ setMethod("summary", # doseRec <- doseMostSelected xMostSelected <- - matchTolerance(doseMostSelected, + match_within_tolerance(doseMostSelected, table = doseGrid ) @@ -2467,7 +2467,7 @@ setMethod("summary", ## ## dose level most often selected as MTD (TDtargetEnd of Trial) xMostSelected <- - matchTolerance(start@doseMostSelected, + match_within_tolerance(start@doseMostSelected, table = doseGrid ) diff --git a/R/checkmate.R b/R/checkmate.R index d52929e49..94e55ca86 100644 --- a/R/checkmate.R +++ b/R/checkmate.R @@ -21,6 +21,94 @@ #' @name assertions NULL +# check equality ---- + +#' Check if All Arguments Are Equal +#' +#' @description `r lifecycle::badge("experimental")` +#' Elements of `...` must be numeric vectors or scalars. +#' +#' This function performs an element-by-element comparison of the first object +#' provided in `...` with every other object in `...` and returns `TRUE` if all +#' comparisons are equal within a given tolerance and `FALSE` otherwise. +#' +#' @param ... (`numeric`)\cr vectors to be compared +#' @param tol (`numeric`)\cr the maximum difference to be tolerated when +#' judging equality +#' +#' @note If there are any missing or infinite values in `...`, this function +#' returns `FALSE`, regardless of the values of other elements in `...`. +#' +#' @note If elements in `...` are not all of the same length, `FALSE` is returned. +#' +#' @return TRUE if all element-by-element differences are less than `tolerance` +#' in magnitude, `FALSE` otherwise. +#' @seealso [`assertions`] for more details. +#' +#' @export +#' @examples +#' check_equal(1:2, 1:2) # TRUE +#' check_equal(1:2, 2:3) # "Not all equal" +#' check_equal(Inf, Inf) # "Not all equal" +#' check_equal(0.01, 0.02) # "Not all equal" +#' check_equal(0.01, 0.02, tol = 0.05) # TRUE +#' check_equal(1, c(1, 1)) # "Not all equal" +check_equal <- function(..., tol = sqrt(.Machine$double.eps)) { + dot_args = list(...) + + sapply(dot_args, assert_numeric) + + tmp <- sapply(dot_args, length) + if (min(tmp) != max(tmp)) return("Not all of same length") + if (any(sapply(dot_args, is.na))) return("Some entries NA") + if (any(sapply(dot_args, is.infinite))) return("Not all entries finite") + if (!all(sapply(dot_args, test_numeric))) return("Not all numeric") + + rv <- test_true( + all( + sapply( + 2:length(dot_args), + function(z) abs(dot_args[[1]] - dot_args[[z]]) < tol + ) + ) + ) + if (rv) return(TRUE) + else return("Not all equal") +} + +# assert equality + +#' Assert That All Arguments Are Equal +#' +#' @description `r lifecycle::badge("experimental")` +#' Elements of `...` must be numeric vectors or scalars. +#' +#' This function performs an element-by-element comparison of the first object +#' provided in `...` with every other object in `...` and throws an error if they +#' are not. +#' +#' @param ... (`numeric`)\cr vectors to be compared +#' @param tol (`numeric`)\cr the maximum difference to be tolerated when +#' judging equality +#' +#' @note If there are any missing or infinite values in `...`, this function +#' throws an error, regardless of the values of other elements in `...`. +#' +#' @note If elements in `...` are not all of the same length, an error is thrown. +#' +#' @return `list(...)`, invisibly. +#' @seealso [`assertions`] for more details. +#' @inheritParams checkmate::assert_numeric +#' +#' @export +#' @examples +#' assert_equal(1:2, 1:2) # no error +#' assert_equal(0.01, 0.02, tol = 0.05) # no error +assert_equal = function(..., tol = sqrt(.Machine$double.eps), .var.name = vname(x), add = NULL) { + res = check_equal(..., tol = tol) + makeAssertion(list(...), res, .var.name, add) +} + # assert_probabilities ---- #' Check if an argument is a probability vector @@ -31,7 +119,7 @@ NULL #' probability, that is a number within (0, 1) interval, that can optionally be #' closed at any side. #' -#' @note If there are any missing or non-finite values in `x`, this functions +#' @note If there are any missing or non-finite values in `x`, this function #' returns `FALSE`, regardless of the values of other elements in `x`. #' #' @param x (`numeric`)\cr vector or matrix with numerical values to check. diff --git a/R/helpers.R b/R/helpers.R index 3042e6816..b48cd1f74 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -80,7 +80,7 @@ positive_number <- setClass( ##' ##' @export ##' @keywords programming -matchTolerance <- function(x, table) { +match_within_tolerance <- function(x, table) { if (length(table) == 0) { return(integer()) } diff --git a/R/mcmc.R b/R/mcmc.R index 05c341bec..510eab91d 100644 --- a/R/mcmc.R +++ b/R/mcmc.R @@ -658,7 +658,7 @@ setMethod("mcmc", w1 <- c(thismodel@eff, eff_obsrv$w_no_dlt) x1 <- c(thismodel@eff_dose, eff_obsrv$x_no_dlt) } - x1Level <- matchTolerance(x1, data@doseGrid) + x1Level <- match_within_tolerance(x1, data@doseGrid) ## betaW is constant, the average of the efficacy values betaW <- rep(mean(w1), data@nGrid) ## sigma2betaW use fixed value or prior mean diff --git a/_pkgdown.yaml b/_pkgdown.yaml index 8405ca0e2..a9edf3b97 100644 --- a/_pkgdown.yaml +++ b/_pkgdown.yaml @@ -415,7 +415,7 @@ reference: - get,Samples,character-method - getMinInfBeta - logit - - matchTolerance + - match_within_tolerance - maxSize - minSize - or-Stopping-Stopping diff --git a/design/ordinal-crm.Rmd b/design/ordinal-crm.Rmd index 5406c9d94..e66ed6a4f 100644 --- a/design/ordinal-crm.Rmd +++ b/design/ordinal-crm.Rmd @@ -357,7 +357,7 @@ DataOrdinal <- function( doseGrid = doseGrid, nObs = length(x), nGrid = length(doseGrid), - xLevel = matchTolerance(x = x, table = doseGrid), + xLevel = match_within_tolerance(x = x, table = doseGrid), placebo = placebo, yCategories = yCategories ) @@ -441,7 +441,7 @@ setMethod( n <- length(y) # Which grid level is the dose? - gridLevel <- matchTolerance(x, object@doseGrid) + gridLevel <- match_within_tolerance(x, object@doseGrid) object@xLevel <- c(object@xLevel, rep(gridLevel, n)) # Add dose. diff --git a/design/ordinal_crm.Rmd b/design/ordinal_crm.Rmd index 3e50d3c32..546c7ece9 100644 --- a/design/ordinal_crm.Rmd +++ b/design/ordinal_crm.Rmd @@ -358,7 +358,7 @@ DataOrdinal <- function( doseGrid = doseGrid, nObs = length(x), nGrid = length(doseGrid), - xLevel = matchTolerance(x = x, table = doseGrid), + xLevel = match_within_tolerance(x = x, table = doseGrid), placebo = placebo, yCategories = yCategories ) @@ -443,7 +443,7 @@ setMethod( n <- length(y) # Which grid level is the dose? - gridLevel <- matchTolerance(x, object@doseGrid) + gridLevel <- match_within_tolerance(x, object@doseGrid) object@xLevel <- c(object@xLevel, rep(gridLevel, n)) # Add dose. diff --git a/man/assert_equal.Rd b/man/assert_equal.Rd new file mode 100644 index 000000000..9103a6aeb --- /dev/null +++ b/man/assert_equal.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/checkmate.R +\name{assert_equal} +\alias{assert_equal} +\title{Assert That All Arguments Are Equal} +\usage{ +assert_equal( + ..., + tol = sqrt(.Machine$double.eps), + .var.name = vname(x), + add = NULL +) +} +\arguments{ +\item{...}{(\code{numeric})\cr vectors to be compared} + +\item{tol}{(\code{numeric})\cr the maximum difference to be tolerated when +judging equality} + +\item{.var.name}{[\code{character(1)}]\cr +Name of the checked object to print in assertions. Defaults to +the heuristic implemented in \code{\link[checkmate]{vname}}.} + +\item{add}{[\code{AssertCollection}]\cr +Collection to store assertion messages. See \code{\link[checkmate]{AssertCollection}}.} +} +\value{ +\code{list(...)}, invisibly. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +Elements of \code{...} must be numeric vectors or scalars. + +This function performs an element-by-element comparison of the first object +provided in \code{...} with every other object in \code{...} and throws an error if they +are not. +} +\note{ +If there are any missing or infinite values in \code{...}, this function +throws an error, regardless of the values of other elements in \code{...}. + +If elements in \code{...} are not all of the same length, an error is thrown. +} +\examples{ +assert_equal(1:2, 1:2) # no error +assert_equal(0.01, 0.02, tol = 0.05) # no error +} +\seealso{ +\code{\link{assertions}} for more details. +} diff --git a/man/check_equal.Rd b/man/check_equal.Rd new file mode 100644 index 000000000..0d154c30d --- /dev/null +++ b/man/check_equal.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/checkmate.R +\name{check_equal} +\alias{check_equal} +\title{Check if All Arguments Are Equal} +\usage{ +check_equal(..., tol = sqrt(.Machine$double.eps)) +} +\arguments{ +\item{...}{(\code{numeric})\cr vectors to be compared} + +\item{tol}{(\code{numeric})\cr the maximum difference to be tolerated when +judging equality} +} +\value{ +TRUE if all element-by-element differences are less than \code{tolerance} +in magnitude, \code{FALSE} otherwise. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +Elements of \code{...} must be numeric vectors or scalars. + +This function performs an element-by-element comparison of the first object +provided in \code{...} with every other object in \code{...} and returns \code{TRUE} if all +comparisons are equal within a given tolerance and \code{FALSE} otherwise. +} +\note{ +If there are any missing or infinite values in \code{...}, this function +returns \code{FALSE}, regardless of the values of other elements in \code{...}. + +If elements in \code{...} are not all of the same length, \code{FALSE} is returned. +} +\examples{ +check_equal(1:2, 1:2) # TRUE +check_equal(1:2, 2:3) # "Not all equal" +check_equal(Inf, Inf) # "Not all equal" +check_equal(0.01, 0.02) # "Not all equal" +check_equal(0.01, 0.02, tol = 0.05) # TRUE +check_equal(1, c(1, 1)) # "Not all equal" +} +\seealso{ +\code{\link{assertions}} for more details. +} diff --git a/man/check_probabilities.Rd b/man/check_probabilities.Rd index 7edd0017e..aa3553704 100644 --- a/man/check_probabilities.Rd +++ b/man/check_probabilities.Rd @@ -87,7 +87,7 @@ probability, that is a number within (0, 1) interval, that can optionally be closed at any side. } \note{ -If there are any missing or non-finite values in \code{x}, this functions +If there are any missing or non-finite values in \code{x}, this function returns \code{FALSE}, regardless of the values of other elements in \code{x}. } \examples{ diff --git a/man/matchTolerance.Rd b/man/match_within_tolerance.Rd similarity index 82% rename from man/matchTolerance.Rd rename to man/match_within_tolerance.Rd index 6c7aa6e0e..8b78cf203 100644 --- a/man/matchTolerance.Rd +++ b/man/match_within_tolerance.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/helpers.R -\name{matchTolerance} -\alias{matchTolerance} +\name{match_within_tolerance} +\alias{match_within_tolerance} \title{Helper function for value matching with tolerance} \usage{ -matchTolerance(x, table) +match_within_tolerance(x, table) } \arguments{ \item{x}{the values to be matched} diff --git a/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo-and-blinding.svg b/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo-and-blinding.svg index fd95cb55f..2c7732976 100644 --- a/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo-and-blinding.svg +++ b/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo-and-blinding.svg @@ -25,207 +25,207 @@ - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -100 - - - - - - - - - - - - - - - - -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -Patient -Dose Level +0 +25 +50 +100 + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +Patient +Dose Level - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 - - - - - - - - - - - - - - - - -0 -50 -100 -150 -Time -Patient - -Toxicity - - - - - - - - - -No -Start -Yes +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 + + + + + + + + + + + + + + + + +0 +50 +100 +150 +Time +Patient + +Toxicity + + + + + + + + + +No +Start +Yes diff --git a/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo.svg b/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo.svg index 42945b844..6ac24bf1a 100644 --- a/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo.svg +++ b/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo.svg @@ -25,231 +25,231 @@ - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - 10 - 11 - 12 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 11 + 12 -0 -25 -50 -100 - - - - - - - - - - - - - - - - -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -Patient -Dose Level +0 +25 +50 +100 + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +Patient +Dose Level - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - 10 - 11 - 12 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 11 + 12 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 - - - - - - - - - - - - - - - - -0 -50 -100 -150 -Time -Patient - -Toxicity - - - - - - - - - -No -Start -Yes +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 + + + + + + + + + + + + + + + + +0 +50 +100 +150 +Time +Patient + +Toxicity + + + + + + + + + +No +Start +Yes diff --git a/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo-and-blinding.svg b/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo-and-blinding.svg index 485c4b78f..9e13fae7c 100644 --- a/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo-and-blinding.svg +++ b/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo-and-blinding.svg @@ -30,78 +30,78 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -100 - - - - - - - - - - - - - - - - -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -Patient -Dose Level +0 +25 +50 +100 + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +Patient +Dose Level @@ -114,67 +114,67 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -25 -50 -75 -100 - - - - - - - - -40 -60 -80 -100 -Dose Level -Biomarker - -Toxicity - - - - -No -Yes +25 +50 +75 +100 + + + + + + + + +40 +60 +80 +100 +Dose Level +Biomarker + +Toxicity + + + + +No +Yes diff --git a/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo.svg b/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo.svg index 1131cd122..faf2ae9b0 100644 --- a/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo.svg +++ b/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo.svg @@ -30,90 +30,90 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - 10 - 11 - 12 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 11 + 12 -0 -25 -50 -100 - - - - - - - - - - - - - - - - -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -Patient -Dose Level +0 +25 +50 +100 + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 +Patient +Dose Level @@ -126,82 +126,82 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 -25 -50 -75 -100 - - - - - - - - - -0 -25 -50 -75 -100 -Dose Level -Biomarker - -Toxicity - - - - -No -Yes +25 +50 +75 +100 + + + + + + + + + +0 +25 +50 +75 +100 +Dose Level +Biomarker + +Toxicity + + + + +No +Yes diff --git a/tests/testthat/test-checkmate.R b/tests/testthat/test-checkmate.R index dda1f5ae1..e671cbd91 100644 --- a/tests/testthat/test-checkmate.R +++ b/tests/testthat/test-checkmate.R @@ -1,3 +1,25 @@ +# check_equal ---- +test_that("check_equal works correctly", { + expect_true(check_equal(1:2, 1:2)) + expect_equal(check_equal(1:2, 2:3), "Not all equal") + expect_equal(check_equal(Inf, Inf), "Not all entries finite") + expect_equal(check_equal(NA, 1), "Some entries NA") + expect_equal(check_equal(0.01, 0.02), "Not all equal") + expect_true(check_equal(0.01, 0.02, tol = 0.05)) + expect_equal(check_equal(1, c(1, 1)), "Not all of same length") +}) + +# assert_equal +test_that("assert_equal works correctly", { + expect_invisible(assert_equal(1:2, 1:2)) + expect_error(assert_equal(1:2, 2:3), "Assertion on 'x' failed: Not all equal.") + expect_error(assert_equal(Inf, Inf), "Assertion on 'x' failed: Not all entries finite.") + expect_error(assert_equal(NA, 1), "Assertion on 'x' failed: Some entries NA") + expect_error(assert_equal(0.01, 0.02), "Assertion on 'x' failed: Not all equal.") + expect_invisible(assert_equal(0.01, 0.02, tol = 0.05)) + expect_error(assert_equal(1, c(1, 1)), "Assertion on 'x' failed: Not all of same length.") +}) + # check_probabilities ---- test_that("check_probabilities returns TRUE as expected", { From ebe046fd8d81a24acd6e8de43320dde9ff4e8a45 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 13 Oct 2023 09:20:29 +0000 Subject: [PATCH 2/5] [skip actions] Restyle files --- R/checkmate.R | 39 +++++++++++++++++++++++++-------------- 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/R/checkmate.R b/R/checkmate.R index 94e55ca86..42a63c0f7 100644 --- a/R/checkmate.R +++ b/R/checkmate.R @@ -54,26 +54,37 @@ NULL #' check_equal(0.01, 0.02, tol = 0.05) # TRUE #' check_equal(1, c(1, 1)) # "Not all equal" check_equal <- function(..., tol = sqrt(.Machine$double.eps)) { - dot_args = list(...) + dot_args <- list(...) sapply(dot_args, assert_numeric) tmp <- sapply(dot_args, length) - if (min(tmp) != max(tmp)) return("Not all of same length") - if (any(sapply(dot_args, is.na))) return("Some entries NA") - if (any(sapply(dot_args, is.infinite))) return("Not all entries finite") - if (!all(sapply(dot_args, test_numeric))) return("Not all numeric") + if (min(tmp) != max(tmp)) { + return("Not all of same length") + } + if (any(sapply(dot_args, is.na))) { + return("Some entries NA") + } + if (any(sapply(dot_args, is.infinite))) { + return("Not all entries finite") + } + if (!all(sapply(dot_args, test_numeric))) { + return("Not all numeric") + } rv <- test_true( - all( - sapply( - 2:length(dot_args), - function(z) abs(dot_args[[1]] - dot_args[[z]]) < tol - ) + all( + sapply( + 2:length(dot_args), + function(z) abs(dot_args[[1]] - dot_args[[z]]) < tol ) ) - if (rv) return(TRUE) - else return("Not all equal") + ) + if (rv) { + return(TRUE) + } else { + return("Not all equal") + } } # assert equality @@ -104,8 +115,8 @@ check_equal <- function(..., tol = sqrt(.Machine$double.eps)) { #' @examples #' assert_equal(1:2, 1:2) # no error #' assert_equal(0.01, 0.02, tol = 0.05) # no error -assert_equal = function(..., tol = sqrt(.Machine$double.eps), .var.name = vname(x), add = NULL) { - res = check_equal(..., tol = tol) +assert_equal <- function(..., tol = sqrt(.Machine$double.eps), .var.name = vname(x), add = NULL) { + res <- check_equal(..., tol = tol) makeAssertion(list(...), res, .var.name, add) } From 861281c632c66cbbeab69a1591890d51a62be1a4 Mon Sep 17 00:00:00 2001 From: Puzzled-Face Date: Fri, 13 Oct 2023 10:21:11 +0000 Subject: [PATCH 3/5] Fixing pkgdown error --- _pkgdown.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/_pkgdown.yaml b/_pkgdown.yaml index a9edf3b97..88abdaa9f 100644 --- a/_pkgdown.yaml +++ b/_pkgdown.yaml @@ -406,6 +406,8 @@ reference: - SimulationsSummary-class - approximate - assertions + - assert_equal + - check_equal - crmPackExample - crmPackHelp - examine From 6c9bf0931834e9d19c323bafd6f1c8330888a83a Mon Sep 17 00:00:00 2001 From: Puzzled-Face Date: Fri, 13 Oct 2023 10:36:36 +0000 Subject: [PATCH 4/5] Lintr complaints --- R/checkmate.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/checkmate.R b/R/checkmate.R index 42a63c0f7..c4c9ff036 100644 --- a/R/checkmate.R +++ b/R/checkmate.R @@ -115,10 +115,12 @@ check_equal <- function(..., tol = sqrt(.Machine$double.eps)) { #' @examples #' assert_equal(1:2, 1:2) # no error #' assert_equal(0.01, 0.02, tol = 0.05) # no error +# nolint start assert_equal <- function(..., tol = sqrt(.Machine$double.eps), .var.name = vname(x), add = NULL) { res <- check_equal(..., tol = tol) makeAssertion(list(...), res, .var.name, add) } +# nolint end # assert_probabilities ---- From c36809b67c5df50a2aca06cac992dfab0398beb6 Mon Sep 17 00:00:00 2001 From: Puzzled-Face Date: Mon, 16 Oct 2023 08:17:42 +0000 Subject: [PATCH 5/5] Responding to review comments. --- R/checkmate.R | 19 ++++++++++--------- tests/testthat/test-checkmate.R | 2 +- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/R/checkmate.R b/R/checkmate.R index c4c9ff036..45d9923ce 100644 --- a/R/checkmate.R +++ b/R/checkmate.R @@ -32,16 +32,16 @@ NULL #' provided in `...` with every other object in `...` and returns `TRUE` if all #' comparisons are equal within a given tolerance and `FALSE` otherwise. #' -#' @param ... (`numeric`)\cr vectors to be compared +#' @param ... (`numeric`)\cr vectors to be compared. #' @param tol (`numeric`)\cr the maximum difference to be tolerated when -#' judging equality +#' judging equality. #' #' @note If there are any missing or infinite values in `...`, this function #' returns `FALSE`, regardless of the values of other elements in `...`. #' #' @note If elements in `...` are not all of the same length, `FALSE` is returned. #' -#' @return TRUE if all element-by-element differences are less than `tolerance` +#' @return `TRUE` if all element-by-element differences are less than `tolerance` #' in magnitude, `FALSE` otherwise. #' @seealso [`assertions`] for more details. #' @@ -72,7 +72,7 @@ check_equal <- function(..., tol = sqrt(.Machine$double.eps)) { return("Not all numeric") } - rv <- test_true( + all_ok <- test_true( all( sapply( 2:length(dot_args), @@ -80,15 +80,12 @@ check_equal <- function(..., tol = sqrt(.Machine$double.eps)) { ) ) ) - if (rv) { + if (all_ok) { return(TRUE) - } else { - return("Not all equal") } + "Not all equal" } -# assert equality - #' Assert That All Arguments Are Equal #' #' @description `r lifecycle::badge("experimental")` @@ -112,11 +109,15 @@ check_equal <- function(..., tol = sqrt(.Machine$double.eps)) { #' @inheritParams checkmate::assert_numeric #' #' @export +#' @rdname check_equal #' @examples #' assert_equal(1:2, 1:2) # no error #' assert_equal(0.01, 0.02, tol = 0.05) # no error # nolint start assert_equal <- function(..., tol = sqrt(.Machine$double.eps), .var.name = vname(x), add = NULL) { + # assert_equal <- makeAssertionFunction(check_equal) fails with error "Error + # in `checkmate::makeAssertion(..., res, .var.name, add)`: unused argument + # (add)", possibly because of the use of ... in check_equal. res <- check_equal(..., tol = tol) makeAssertion(list(...), res, .var.name, add) } diff --git a/tests/testthat/test-checkmate.R b/tests/testthat/test-checkmate.R index e671cbd91..91ef4c657 100644 --- a/tests/testthat/test-checkmate.R +++ b/tests/testthat/test-checkmate.R @@ -9,7 +9,7 @@ test_that("check_equal works correctly", { expect_equal(check_equal(1, c(1, 1)), "Not all of same length") }) -# assert_equal +# assert_equal ---- test_that("assert_equal works correctly", { expect_invisible(assert_equal(1:2, 1:2)) expect_error(assert_equal(1:2, 2:3), "Assertion on 'x' failed: Not all equal.")