739: add h_simulations_output_format

R/Design-methods.R

@@ -308,33 +308,34 @@ setMethod("simulate",
 
       ## 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")
+      # ## 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")
+      simulations_output <- h_simulations_ouptput_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
       )
 

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.
@@ -187,3 +188,43 @@ 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_ouptput_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
+  ))
+}

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