add feature needed to stop mono arm when combo arm stops

R/Design-class.R

@@ -552,6 +552,8 @@ DADesign <- function(model, data,
 #'   concurrent mono and combo cohorts.
 #' @slot same_dose (`flag`)\cr whether the lower dose of the separately determined mono and combo
 #'   doses should be used as the next dose for both mono and combo.
+#' @slot stop_mono_with_combo (`flag`)\cr whether the mono arm should be stopped when the combo
+#'   arm is stopped (this makes sense when the only real trial objective is the recommended combo dose).
 #'
 #' @details Note that the model slots inside the `mono` and `combo` parameters
 #'   are ignored (because we don't fit separate regression models for the mono and
@@ -568,14 +570,16 @@ DADesign <- function(model, data,
     mono = "Design",
     combo = "Design",
     first_cohort_mono_only = "logical",
-    same_dose = "logical"
+    same_dose = "logical",
+    stop_mono_with_combo = "logical"
   ),
   prototype = prototype(
     model = .DefaultLogisticLogNormalGrouped(),
     mono = .Design(),
     combo = .Design(),
     first_cohort_mono_only = TRUE,
-    same_dose = TRUE
+    same_dose = TRUE,
+    stop_mono_with_combo = FALSE
   ),
   validity = v_design_grouped,
   contains = "CrmPackClass"
@@ -590,6 +594,7 @@ DADesign <- function(model, data,
 #' @param combo (`Design`)\cr see slot definition.
 #' @param first_cohort_mono_only (`flag`)\cr see slot definition.
 #' @param same_dose (`flag`)\cr see slot definition.
+#' @param stop_mono_with_combo (`flag`)\cr see slot definition.
 #' @param ... not used.
 #'
 #' @export
@@ -600,13 +605,15 @@ DesignGrouped <- function(model,
                           combo = mono,
                           first_cohort_mono_only = TRUE,
                           same_dose = TRUE,
+                          stop_mono_with_combo = FALSE,
                           ...) {
   .DesignGrouped(
     model = model,
     mono = mono,
     combo = combo,
     first_cohort_mono_only = first_cohort_mono_only,
-    same_dose = same_dose
+    same_dose = same_dose,
+    stop_mono_with_combo = stop_mono_with_combo
   )
 }
 

R/Design-methods.R

@@ -4659,6 +4659,14 @@ setMethod(
           if (object@same_dose && !current$mono$stop && !current$combo$stop) {
             current$mono$dose <- current$combo$dose <- min(current$mono$dose, current$combo$dose)
           }
+          if (current$combo$stop && !current$mono$stop && object@stop_mono_with_combo) {
+            current$mono$stop <- structure(
+              TRUE,
+              message = "mono stopped because combo stopped",
+              report_label = "mono stopped because combo stopped"
+            )
+            current$mono$results <- h_unpack_stopit(current$mono$stop)
+          }
           if (current$first) current$first <- FALSE
         }
         current$mono$fit <- fit(current$samples, object@model, current$grouped, group = "mono")

R/Design-validity.R

@@ -41,5 +41,9 @@ v_design_grouped <- function(object) {
     test_flag(object@same_dose),
     "same_dose must be a flag"
   )
+  v$check(
+    test_flag(object@stop_mono_with_combo),
+    "stop_mono_with_combo must be a flag"
+  )
   v$result()
 }

examples/Design-class-DesignGrouped.R

@@ -40,16 +40,30 @@ my_increments <- IncrementsRelative(
   increments = c(1, 0.33)
 )
 
+# Rules to be used for both arms.
+one_arm <- Design(
+  model = .DefaultModelLogNormal(), # Ignored.
+  nextBest = my_next_best,
+  stopping = my_stopping,
+  increments = my_increments,
+  cohort_size = my_size,
+  data = empty_data,
+  startingDose = 3
+)
+
 # Initialize the design.
 design <- DesignGrouped(
   model = my_model,
-  mono = Design(
-    model = .DefaultModelLogNormal(), # Ignored.
-    nextBest = my_next_best,
-    stopping = my_stopping,
-    increments = my_increments,
-    cohort_size = my_size,
-    data = empty_data,
-    startingDose = 3
-  )
+  mono = one_arm
+)
+
+# Alternative options: Here e.g. use both mono and combo from the start,
+# but allow different dose levels for the cohorts. Stop mono arm too, when combo
+# arm is stopped.
+design2 <- DesignGrouped(
+  model = my_model,
+  mono = one_arm,
+  first_cohort_mono_only = FALSE,
+  same_dose = FALSE,
+  stop_mono_with_combo = TRUE,
 )

tests/testthat/test-Design-methods.R

@@ -330,6 +330,62 @@ test_that("simulate for DesignGrouped works with different starting doses and fi
   expect_true(all(combo_trial@xLevel[1:3] == 5))
 })
 
+test_that("simulate for DesignGrouped allows to stop mono when combo stops", {
+  mono_arm <- Design(
+    model = .LogisticNormal(),
+    nextBest = NextBestNCRM(target = c(0.3, 0.6), overdose = c(0.6, 1), max_overdose_prob = 0.7),
+    stopping = StoppingMinPatients(nPatients = 20),
+    increments = IncrementsDoseLevels(levels = 5),
+    cohort_size = CohortSizeConst(3),
+    data = Data(doseGrid = 1:100),
+    startingDose = 10
+  )
+  combo_arm <- .Design(
+    mono_arm,
+    stopping = StoppingMinPatients(nPatients = 1) # Such that we stop after the first cohort.
+  )
+  object <- DesignGrouped(
+    model = LogisticLogNormalGrouped(mean = rep(-1, 4), cov = diag(5, 4), ref_dose = 1),
+    mono = mono_arm,
+    combo = combo_arm,
+    same_dose = FALSE,
+    first_cohort_mono_only = FALSE,
+    stop_mono_with_combo = TRUE
+  )
+  my_truth <- function(x) plogis(-4 + 0.2 * log(x / 0.1))
+  my_combo_truth <- function(x) plogis(-4 + 0.5 * log(x / 0.1))
+
+  result <- expect_silent(simulate(
+    object,
+    nsim = 2,
+    seed = 123,
+    truth = my_truth,
+    combo_truth = my_combo_truth,
+    mcmcOptions = h_get_mcmc_options()
+  ))
+
+  expect_list(result)
+  expect_names(names(result), identical.to = c("mono", "combo"))
+  expect_valid(result$mono, "Simulations")
+  expect_valid(result$combo, "Simulations")
+
+  # We see the expected stop reasons.
+  expect_identical(
+    result$mono@stop_reasons,
+    rep(list("mono stopped because combo stopped"), 2)
+  )
+  expect_identical(
+    result$combo@stop_reasons,
+    rep(list("Number of patients is 3 and thus reached the prespecified minimum number 1"), 2)
+  )
+
+  # But mono still had the initial 3 patients in both simulations.
+  expect_identical(
+    lapply(result$mono@data, slot, "nObs"),
+    rep(list(3L), 2)
+  )
+})
+
 # examine ----
 
 ## DADesign ----

tests/testthat/test-Design-validity.R

@@ -74,11 +74,13 @@ test_that("v_design_grouped messages wrong flag slots as expected", {
 
   object@same_dose <- c(NA, TRUE)
   object@first_cohort_mono_only <- logical()
+  object@stop_mono_with_combo <- c(FALSE, FALSE)
 
   result <- v_design_grouped(object)
   expected <- c(
     "first_cohort_mono_only must be a flag",
-    "same_dose must be a flag"
+    "same_dose must be a flag",
+    "stop_mono_with_combo must be a flag"
   )
   expect_identical(result, expected)
 })