Refactoring matchTolerance

DESCRIPTION

@@ -42,7 +42,6 @@ Imports:
     checkmate (>= 2.2.0),
     futile.logger,
     GenSA,
-    grid,
     magrittr,
     gridExtra,
     lifecycle,

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)

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
   )

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.

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.
 

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.

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))

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
         )
 

R/checkmate.R

@@ -21,6 +21,108 @@
 #' @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")
+  }
+
+  all_ok <- test_true(
+    all(
+      sapply(
+        2:length(dot_args),
+        function(z) abs(dot_args[[1]] - dot_args[[z]]) < tol
+      )
+    )
+  )
+  if (all_ok) {
+    return(TRUE)
+  }
+  "Not all equal"
+}
+
+#' 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
+#' @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)
+}
+# nolint end
+
 # assert_probabilities ----
 
 #' Check if an argument is a probability vector
@@ -31,7 +133,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.

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())
   }

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

_pkgdown.yaml

@@ -406,6 +406,8 @@ reference:
       - SimulationsSummary-class
       - approximate
       - assertions
+      - assert_equal
+      - check_equal
       - crmPackExample
       - crmPackHelp
       - examine
@@ -415,7 +417,7 @@ reference:
       - get,Samples,character-method
       - getMinInfBeta
       - logit
-      - matchTolerance
+      - match_within_tolerance
       - maxSize
       - minSize
       - or-Stopping-Stopping

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.

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.