Fixes first cohort logic for grouped design simulation (#684)

openpharma · Sep 30, 2023 · 43a8606 · 43a8606
1 parent 7c6ed0e
commit 43a8606
Show file tree

Hide file tree

Showing 2 changed files with 53 additions and 2 deletions.
diff --git a/R/Design-methods.R b/R/Design-methods.R
@@ -4667,7 +4667,6 @@ setMethod(
             current$combo$data <- current$combo$data |>
               h_add_dlts(current$combo$dose, current$combo$truth, object@combo@cohort_size, firstSeparate)
           }
-          if (current$first) current$first <- FALSE
           current$grouped <- h_group_data(current$mono$data, current$combo$data)
           current$samples <- mcmc(current$grouped, object@model, mcmcOptions)
           if (!current$mono$stop) {
@@ -4679,7 +4678,7 @@ setMethod(
               stopTrial(current$mono$dose, current$samples, object@model, current$mono$data, group = "mono")
             current$mono$results <- h_unpack_stopit(current$mono$stop)
           }
-          if (!current$combo$stop) {
+          if (!current$combo$stop && (!current$first || !object@first_cohort_mono_only)) {
             current$combo$limit <- if (is.na(current$mono$dose)) {
               0
             } else {
@@ -4696,6 +4695,7 @@ 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$first) current$first <- FALSE
         }
         current$mono$fit <- fit(current$samples, object@model, current$grouped, group = "mono")
         current$combo$fit <- fit(current$samples, object@model, current$grouped, group = "combo")

diff --git a/tests/testthat/test-Design-methods.R b/tests/testthat/test-Design-methods.R
@@ -279,6 +279,57 @@ test_that("simulate for DesignGrouped works when first patient is dosed separate
   expect_true(combo_trial@x[1] == 1)
 })
 
+test_that("simulate for DesignGrouped works with different starting doses and first mono", {
+  object <- DesignGrouped(
+    model = LogisticLogNormalGrouped(mean = rep(-1, 4), cov = diag(5, 4), ref_dose = 1),
+    mono = Design(
+      model = .LogisticNormal(),
+      nextBest = NextBestNCRM(target = c(0.3, 0.6), overdose = c(0.6, 1), max_overdose_prob = 0.7),
+      stopping = StoppingMinPatients(nPatients = 9),
+      increments = IncrementsDoseLevels(levels = 5),
+      cohort_size = CohortSizeConst(3),
+      data = Data(doseGrid = 1:100),
+      startingDose = 10
+    ),
+    combo = Design(
+      model = .LogisticNormal(),
+      nextBest = NextBestNCRM(target = c(0.3, 0.6), overdose = c(0.6, 1), max_overdose_prob = 0.7),
+      stopping = StoppingMinPatients(nPatients = 9),
+      increments = IncrementsRelative(c(0, 100), c(2, 1)),
+      cohort_size = CohortSizeConst(3),
+      data = Data(doseGrid = 1:100),
+      startingDose = 5
+    ),
+    same_dose = FALSE,
+    first_cohort_mono_only = 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")
+
+  mono_trial <- result$mono@data[[2L]]
+  combo_trial <- result$combo@data[[2L]]
+
+  # First cohort is only mono at the starting dose.
+  expect_true(all(mono_trial@xLevel[1:3] == 10))
+
+  # In first combo cohort we have the expected starting dose.
+  expect_true(all(combo_trial@xLevel[1:3] == 5))
+})
+
 # examine ----
 
 ## DADesign ----