Merge branch 'main' into 656_additional_stat

.lintr

@@ -2,7 +2,7 @@ linters: linters_with_defaults(
   line_length_linter = line_length_linter(120),
   cyclocomp_linter = NULL,
   object_usage_linter = NULL,
-  trailing_blank_lines_linter = NULL,
-  trailing_whitespace_linter = NULL,
+  object_length_linter = NULL,
+  indentation_linter = NULL,
   object_name_linter = object_name_linter(c("CamelCase", "camelCase", "snake_case"))
  )

NAMESPACE

@@ -17,6 +17,7 @@ export(.DASimulations)
 export(.Data)
 export(.DataDA)
 export(.DataDual)
+export(.DataGrouped)
 export(.DataMixture)
 export(.DataParts)
 export(.DefaultCohortSizeConst)
@@ -26,6 +27,7 @@ export(.DefaultCohortSizeMin)
 export(.DefaultCohortSizeParts)
 export(.DefaultCohortSizeRange)
 export(.DefaultDALogisticLogNormal)
+export(.DefaultDataGrouped)
 export(.DefaultDualEndpoint)
 export(.DefaultDualEndpointBeta)
 export(.DefaultDualEndpointEmax)
@@ -181,6 +183,7 @@ export(DASimulations)
 export(Data)
 export(DataDA)
 export(DataDual)
+export(DataGrouped)
 export(DataMixture)
 export(DataParts)
 export(Design)
@@ -365,6 +368,7 @@ exportClasses(DASimulations)
 exportClasses(Data)
 exportClasses(DataDA)
 exportClasses(DataDual)
+exportClasses(DataGrouped)
 exportClasses(DataMixture)
 exportClasses(DataParts)
 exportClasses(Design)

NEWS.md

@@ -1,4 +1,5 @@
 # Version 1.0.9000.9133
+* Added new `DataGrouped` class to support simultaneous dose escalation with monotherapy and combination therapy.
 * Created the `CrmPackClass` class as the ultimate ancestor of all other 
 `crmPack` classes to allow identification of crmPack classes and simpler 
 definition of generic methods.

R/Data-class.R

@@ -379,3 +379,66 @@ DataDA <- function(u = numeric(),
     Tmax = as.numeric(Tmax)
   )
 }
+
+# DataGrouped ----
+
+## class ----
+
+#' `DataGrouped`
+#'
+#' @description `r lifecycle::badge("stable")`
+#'
+#' [`DataGrouped`] is a class for a two groups dose escalation data set,
+#' comprised of a monotherapy (`mono`) and a combination therapy (`combo`)
+#' arm. It inherits from [`Data`] and it contains the additional group information.
+#'
+#' @slot group (`factor`)\cr whether `mono` or `combo` was used.
+#'
+#' @aliases DataGrouped
+#' @export
+.DataGrouped <- setClass(
+  Class = "DataGrouped",
+  slots = c(
+    group = "factor"
+  ),
+  prototype = prototype(
+    group = factor(levels = c("mono", "combo"))
+  ),
+  contains = "Data",
+  validity = v_data_grouped
+)
+
+## constructor ----
+
+#' @rdname DataGrouped-class
+#'
+#' @param group (`factor` or `character`)\cr whether `mono` or `combo` was used.
+#'   If `character` then will be coerced to `factor` with the correct levels
+#'   internally.
+#' @param ... parameters passed to [Data()].
+#'
+#' @export
+#' @example examples/Data-class-DataGrouped.R
+#'
+DataGrouped <- function(group = character(),
+                        ...) {
+  d <- Data(...)
+  if (!is.factor(group)) {
+    assert_character(group)
+    assert_subset(group, choices = c("mono", "combo"))
+    group <- factor(group, levels = c("mono", "combo"))
+  }
+  .DataGrouped(
+    d,
+    group = group
+  )
+}
+
+## default constructor ----
+
+#' @rdname DataGrouped-class
+#' @note Typically, end users will not use the `.DefaultDataGrouped()` function.
+#' @export
+.DefaultDataGrouped <- function() {
+  DataGrouped()
+}

R/Data-methods.R

@@ -35,7 +35,7 @@ setMethod(
       return()
     }
 
-    df <- h_plot_data_df(x, blind)
+    df <- h_plot_data_df(x, blind, ...)
 
     p <- ggplot(df, aes(x = patient, y = dose)) +
       geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +

R/Data-validity.R

@@ -180,3 +180,19 @@ v_data_da <- function(object) {
   )
   v$result()
 }
+
+#' @describeIn v_data_objects validates that the [`DataGrouped`] object
+#'   contains valid group information.
+v_data_grouped <- function(object) {
+  v <- Validate()
+  v$check(
+    test_factor(
+      object@group,
+      levels = c("mono", "combo"),
+      len = object@nObs,
+      any.missing = FALSE
+    ),
+    "group must be factor with levels mono and combo of length nObs without missings"
+  )
+  v$result()
+}

R/Rules-methods.R

@@ -150,7 +150,7 @@ setMethod(
   ),
   definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
     # Matrix with samples from the dose-tox curve at the dose grid points.
-    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples)
+    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)
 
     # Estimates of posterior probabilities that are based on the prob. samples
     # which are within overdose/target interval.
@@ -2229,8 +2229,8 @@ setMethod(
       is.na(dose),
       0,
       mean(
-        prob(dose = dose, model, samples) >= stopping@target[1] &
-          prob(dose = dose, model, samples) <= stopping@target[2]
+        prob(dose = dose, model, samples, ...) >= stopping@target[1] &
+          prob(dose = dose, model, samples, ...) <= stopping@target[2]
       )
     )
 
@@ -2486,8 +2486,10 @@ setMethod(
           biom_level_samples, 1L,
           function(x) {
             rnx <- range(x)
-            min(which((x >= stopping@target[1] * diff(rnx) + rnx[1]) &
-              (x <= stopping@target[2] * diff(rnx) + rnx[1] + 1e-10)))
+            min(which(
+              (x >= stopping@target[1] * diff(rnx) + rnx[1]) &
+                (x <= stopping@target[2] * diff(rnx) + rnx[1] + 1e-10)
+            ))
           }
         )
         prob_target <- numeric(ncol(biom_level_samples))
@@ -2504,8 +2506,7 @@ setMethod(
       prob_target <- sapply(
         seq(1, ncol(biom_level_samples)),
         function(x) {
-          sum(biom_level_samples[, x] >= stopping@target[1] &
-            biom_level_samples[, x] <= stopping@target[2]) /
+          sum(biom_level_samples[, x] >= stopping@target[1] & biom_level_samples[, x] <= stopping@target[2]) /
             nrow(biom_level_samples)
         }
       )

R/Samples-methods.R

@@ -165,7 +165,7 @@ setMethod("get",
 #' @param object the \code{\linkS4class{Samples}} object
 #' @param model the \code{\linkS4class{GeneralModel}} object
 #' @param data the \code{\linkS4class{Data}} object
-#' @param \dots unused
+#' @param \dots passed down to the [prob()] method.
 #' @return the data frame with required information (see method details)
 #'
 #' @export
@@ -232,7 +232,8 @@ setMethod("fit",
         probSamples[, i] <- prob(
           dose = points[i],
           model,
-          object
+          object,
+          ...
         )
       }
 
@@ -532,7 +533,8 @@ setMethod("plot",
         model = y,
         data = data,
         quantiles = c(0.025, 0.975),
-        middle = mean
+        middle = mean,
+        ...
       )
 
       ## make the plot
@@ -1642,10 +1644,10 @@ setMethod("plotGain",
           data = point_data,
           inherit.aes = FALSE,
           aes(
-            x = X,
-            y = Y,
-            shape = as.factor(Shape),
-            fill = Colour
+            x = .data$X,
+            y = .data$Y,
+            shape = as.factor(.data$Shape),
+            fill = .data$Colour
           ),
           colour = point_data$Colour,
           size = point_data$Size,

R/Simulations-methods.R

@@ -181,10 +181,11 @@ setMethod("plot",
           sapply(
             simDoses,
             function(s) {
-              prop.table(table(factor(s,
-                levels =
-                  x@data[[1]]@doseGrid
-              )))
+              if (length(s) > 0) {
+                prop.table(table(factor(s, levels = x@data[[1]]@doseGrid)))
+              } else {
+                rep(0, length(x@data[[1]]@doseGrid))
+              }
             }
           )
 

R/helpers.R

@@ -1080,3 +1080,39 @@ h_calc_report_label_percentage <- function(stop_report) {
   stop_pct_to_print <- stop_pct[!is.na(names(stop_pct))]
   return(stop_pct_to_print)
 }
+
+#' Group Together Mono and Combo Data
+#'
+#' This is only used in the simulation method for `DesignGrouped` to combine
+#' the separately generated data sets from mono and combo arms and to fit the
+#' combined logistic regression model.
+#' Hence the ID and cohort information is not relevant and will be
+#' arbitrarily assigned to avoid problems with the [`DataGrouped`] validation.
+#'
+#' @param mono_data (`Data`)\cr mono data.
+#' @param combo_data (`Data`)\cr combo data.
+#'
+#' @return A [`DataGrouped`] object containing both `mono_data` and `combo_data`,
+#'   but with arbitrary ID and cohort slots.
+#'
+#' @keywords internal
+h_group_data <- function(mono_data, combo_data) {
+  assert_class(mono_data, "Data")
+  assert_class(combo_data, "Data")
+
+  df <- data.frame(
+    x = c(mono_data@x, combo_data@x),
+    y = c(mono_data@y, combo_data@y),
+    group = rep(c("mono", "combo"), c(length(mono_data@x), length(combo_data@x)))
+  )
+  df <- df[order(df$x), ]
+
+  DataGrouped(
+    x = df$x,
+    y = df$y,
+    ID = seq_along(df$x),
+    cohort = as.integer(factor(df$x)),
+    doseGrid = sort(unique(c(mono_data@doseGrid, combo_data@doseGrid))),
+    group = df$group
+  )
+}

_pkgdown.yaml

@@ -41,6 +41,7 @@ reference:
       - DataParts
       - DataMixture
       - DataDA
+      - DataGrouped
       - McmcOptions
       - ModelParamsNormal
       - GeneralModel