739: add h_simulations_output_format (#765)

* work-in-progress commit for creation of h_simulations_output_format test case * Added test for h_simulations_output_format * Update helpers_design.R * Update test-helpers_design.R * [skip actions] Restyle files * Update test-helpers_design.R to correct linter errors * [skip actions] Restyle files * Update test-helpers_design.R * Update R/helpers_design.R Co-authored-by: Daniel Sabanes Bove <[email protected]> * Update tests/testthat/test-helpers_design.R Co-authored-by: Daniel Sabanes Bove <[email protected]> * Update Design-methods.R * Update test-helpers_design.R * Update helpers_design.R --------- Co-authored-by: Robert Adams <[email protected]> Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Co-authored-by: Daniel Sabanes Bove <[email protected]>
openpharma · Dec 14, 2023 · 902f20d · 902f20d
1 parent a229b7b
commit 902f20d
Show file tree

Hide file tree

Showing 3 changed files with 77 additions and 26 deletions.
diff --git a/R/Design-methods.R b/R/Design-methods.R
@@ -306,35 +306,17 @@ setMethod("simulate",
         n_cores = nCores
       )
 
-      ## put everything in the Simulations format:
-
-      ## setup the list for the simulated data objects
-      dataList <- lapply(resultList, "[[", "data")
-
-      ## the vector of the final dose recommendations
-      recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))
-
-      ## setup the list for the final fits
-      fitList <- lapply(resultList, "[[", "fit")
-
-      ## the reasons for stopping
-      stopReasons <- lapply(resultList, "[[", "stop")
-
-      # individual stopping rule results as matrix, labels as column names
-      stopResults <- lapply(resultList, "[[", "report_results")
-      stop_matrix <- as.matrix(do.call(rbind, stopResults))
-
-      # Result list of additional statistical summary.
-      additional_stats <- lapply(resultList, "[[", "additional_stats")
+      # format simulation output
+      simulations_output <- h_simulations_output_format(resultList)
 
       ## return the results in the Simulations class object
       ret <- Simulations(
-        data = dataList,
-        doses = recommendedDoses,
-        fit = fitList,
-        stop_report = stop_matrix,
-        stop_reasons = stopReasons,
-        additional_stats = additional_stats,
+        data = simulations_output$dataList,
+        doses = simulations_output$recommendedDoses,
+        fit = simulations_output$fitList,
+        stop_report = simulations_output$stop_matrix,
+        stop_reasons = simulations_output$stopReasons,
+        additional_stats = simulations_output$additional_stats,
         seed = RNGstate
       )
 

diff --git a/R/helpers_design.R b/R/helpers_design.R
@@ -168,6 +168,7 @@ h_add_dlts <- function(data,
 }
 
 
+
 #' Helper Function to call truth calculation
 #'
 #' @param dose (`number`)\cr current dose.
@@ -189,6 +190,46 @@ h_this_truth <- function(dose, this_args, truth) {
 }
 
 
+#' Helper Function to create return list for Simulations output
+#'
+#' @param resultList (`list`)\cr raw iteration output.
+#'
+#' @return aggregated output for simulation object `list`.
+#'
+#' @keywords internal
+h_simulations_output_format <- function(resultList) {
+  ## put everything in the Simulations format:
+
+  ## setup the list for the simulated data objects
+  dataList <- lapply(resultList, "[[", "data")
+
+  ## the vector of the final dose recommendations
+  recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))
+
+  ## setup the list for the final fits
+  fitList <- lapply(resultList, "[[", "fit")
+
+  ## the reasons for stopping
+  stopReasons <- lapply(resultList, "[[", "stop")
+
+  # individual stopping rule results as matrix, labels as column names
+  stopResults <- lapply(resultList, "[[", "report_results")
+  stop_matrix <- as.matrix(do.call(rbind, stopResults))
+
+  # Result list of additional statistical summary.
+  additional_stats <- lapply(resultList, "[[", "additional_stats")
+
+  return(list(
+    dataList = dataList,
+    recommendedDoses = recommendedDoses,
+    fitList = fitList,
+    stopReasons = stopReasons,
+    stopResults = stopResults,
+    additional_stats = additional_stats,
+    stop_matrix = stop_matrix
+  ))
+}
+
 
 #' Helper function to recursively unpack stopping rules and return lists with
 #' logical value and label given

diff --git a/tests/testthat/test-helpers_design.R b/tests/testthat/test-helpers_design.R
@@ -99,6 +99,34 @@ test_that("h_add_dlts works as expected when first separate patient does not hav
   expect_true(data@nObs + 3 == result@nObs)
 })
 
+
+test_that("h_simulations_output_format returns object as expected", {
+  data_test <- new("Data", nGrid = 3L, doseGrid = c(1, 3, 5))
+  dose <- 20
+  fit <- data.frame(middle = c(0.2, 0.7), lower = c(0.1, 0.5), upper = c(0.3, 0.4))
+  stop <- list(list("Number of cohorts is 10 and thus reached the prespecified minimum number 3"))
+  report_results <- c(TRUE, TRUE, TRUE, TRUE, TRUE)
+  names(report_results) <- c(NA, NA, NA, NA, NA)
+  additional_stats <- list()
+
+  result_list_test <- list(list(
+    data = data_test,
+    dose = dose,
+    fit = fit,
+    stop = stop,
+    report_results = report_results,
+    additional_stats = additional_stats
+  ))
+
+  simulations_output <- h_simulations_output_format(result_list_test)
+
+  expect_equal(simulations_output$dataList[[1]], data_test)
+  expect_equal(simulations_output$recommendedDoses, dose)
+  expect_equal(simulations_output$fitList[[1]], fit)
+  expect_equal(simulations_output$stop_matrix, do.call(rbind, lapply(result_list_test, "[[", "report_results")))
+})
+
+
 test_that("h_this_truth returns correct results for given dose", {
   args <- NULL
   args <- as.data.frame(args)