diff --git a/DESCRIPTION b/DESCRIPTION index fcca6d997..9a666fe19 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -99,6 +99,7 @@ Collate: 'Samples-validity.R' 'Samples-class.R' 'mcmc.R' + 'Simulations-validity.R' 'Simulations-class.R' 'helpers_rules.R' 'Model-methods.R' diff --git a/NEWS.md b/NEWS.md index 66f5ee572..39963ad73 100644 --- a/NEWS.md +++ b/NEWS.md @@ -59,6 +59,8 @@ usable instances of all concrete subclasses of `Increments`, `Model`, `NextBest` * Include rolling CRM design, which was previously only available in a separate GitHub branch. * Additional authors and change of maintainer. +* Included 'additional_stats' to add reporting of additional parameters to method simulate to summarize MTD. +* 'report_label' can be added to stopping rules for individual or combined stopping rule reporting. # Version 1.0.0 diff --git a/R/Design-methods.R b/R/Design-methods.R index e82331454..fa959e688 100644 --- a/R/Design-methods.R +++ b/R/Design-methods.R @@ -38,6 +38,9 @@ NULL ##' @param nCores how many cores should be used for parallel computing? ##' Defaults to the number of cores on the machine, maximum 5. ##' @param \dots not used +##' @param derive a named list of functions which derives statistics, based on the +##' vector of posterior MTD samples. Each list element must therefore accept +##' one and only one argument, which is a numeric vector, and return a number. ##' ##' @return an object of class \code{\linkS4class{Simulations}} ##' @@ -57,7 +60,7 @@ setMethod("simulate", truth, args = NULL, firstSeparate = FALSE, mcmcOptions = McmcOptions(), parallel = FALSE, nCores = - min(parallel::detectCores(), 5L), + min(parallel::detectCores(), 5), derive = list(), ...) { ## checks and extracts assert_function(truth) @@ -259,6 +262,18 @@ setMethod("simulate", data = thisData ) + # Get the MTD estimate from the samples. + + target_dose_samples <- dose( + mean(object@nextBest@target), + model = object@model, + samples = thisSamples + ) + + # Create a function for additional statistical summary. + + additional_stats <- lapply(derive, function(f) f(target_dose_samples)) + ## return the results thisResult <- list( @@ -273,7 +288,8 @@ setMethod("simulate", stopit, "message" ), - report_results = stopit_results + report_results = stopit_results, + additional_stats = additional_stats ) return(thisResult) } @@ -313,6 +329,9 @@ setMethod("simulate", 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 the results in the Simulations class object ret <- Simulations( data = dataList, @@ -320,6 +339,7 @@ setMethod("simulate", fit = fitList, stop_report = stop_matrix, stop_reasons = stopReasons, + additional_stats = additional_stats, seed = RNGstate ) @@ -528,6 +548,9 @@ setMethod("simulate", ##' @param nCores how many cores should be used for parallel computing? ##' Defaults to the number of cores on the machine, maximum 5. ##' @param \dots not used +##' @param derive a named list of functions which derives statistics, based on the +##' vector of posterior MTD samples. Each list element must therefore accept +##' one and only one argument, which is a numeric vector, and return a number. ##' ##' @return an object of class \code{\linkS4class{DualSimulations}} ##' @@ -546,7 +569,7 @@ setMethod("simulate", mcmcOptions = McmcOptions(), parallel = FALSE, nCores = - min(parallel::detectCores(), 5L), + min(parallel::detectCores(), 5), derive = list(), ...) { ## checks and extracts assert_function(trueTox) @@ -837,6 +860,19 @@ setMethod("simulate", data = thisData ) + # Get the MTD estimate from the samples. + + target_dose_samples <- dose( + mean(object@nextBest@target), + model = object@model, + samples = thisSamples + ) + + # Create a function for additional statistical summary. + + additional_stats <- lapply(derive, function(f) f(target_dose_samples)) + + ## return the results thisResult <- list( @@ -861,7 +897,8 @@ setMethod("simulate", attr( stopit, "message" - ) + ), + additional_stats = additional_stats ) return(thisResult) @@ -912,6 +949,9 @@ setMethod("simulate", ## for dual simulations as it would fail in summary otherwise (for dual simulations reporting is not implemented) stop_report <- matrix(TRUE, nrow = nsim) + ## For dual simulations summary of additional statistics. + additional_stats <- lapply(resultList, "[[", "additional_stats") + ## return the results in the DualSimulations class object ret <- DualSimulations( data = dataList, @@ -922,6 +962,7 @@ setMethod("simulate", fit_biomarker = fitBiomarkerList, stop_report = stop_report, stop_reasons = stopReasons, + additional_stats = additional_stats, seed = RNGstate ) @@ -3968,6 +4009,9 @@ setMethod("simulate", ##' @param nCores how many cores should be used for parallel computing? ##' Defaults to the number of cores on the machine (maximum 5) ##' @param \dots not used +##' @param derive a named list of functions which derives statistics, based on the +##' vector of posterior MTD samples. Each list element must therefore accept +##' one and only one argument, which is a numeric vector, and return a number. ##' ##' @return an object of class \code{\linkS4class{Simulations}} ##' @@ -3987,7 +4031,8 @@ setMethod("simulate", deescalate = TRUE, mcmcOptions = McmcOptions(), DA = TRUE, - parallel = FALSE, nCores = min(parallel::detectCores(), 5L), + parallel = FALSE, nCores = min(parallel::detectCores(), 5), + derive = list(), ...) { ## checks and extracts assert_function(truthTox) @@ -4456,6 +4501,19 @@ setMethod("simulate", data = thisData ) + # Get the MTD estimate from the samples. + + target_dose_samples <- dose( + mean(object@nextBest@target), + model = object@model, + samples = thisSamples + ) + + # Create a function for additional statistical summary. + + additional_stats <- lapply(derive, function(f) f(target_dose_samples)) + + ## return the results thisResult <- list( @@ -4470,7 +4528,8 @@ setMethod("simulate", attr( stopit, "message" - ) + ), + additional_stats = additional_stats ) return(thisResult) } @@ -4514,6 +4573,9 @@ setMethod("simulate", stopReasons <- lapply(resultList, "[[", "stop") stop_report <- matrix(TRUE, nrow = nsim) + + additional_stats <- lapply(resultList, "[[", "additional_stats") + ## return the results in the Simulations class object ret <- DASimulations( data = dataList, @@ -4521,10 +4583,12 @@ setMethod("simulate", fit = fitList, trialduration = trialduration, stop_report = stop_report, + additional_stats = additional_stats, stop_reasons = stopReasons, seed = RNGstate ) + return(ret) } ) @@ -4686,6 +4750,7 @@ setMethod( stop_reasons <- lapply(this_list, "[[", "stop") report_results <- lapply(this_list, "[[", "results") stop_report <- as.matrix(do.call(rbind, report_results)) + additional_stats <- lapply(this_list, "[[", "additional_stats") Simulations( data = data_list, @@ -4693,6 +4758,7 @@ setMethod( fit = fit_list, stop_reasons = stop_reasons, stop_report = stop_report, + additional_stats = additional_stats, seed = rng_state ) }) diff --git a/R/Simulations-class.R b/R/Simulations-class.R index af933d8be..584d919ba 100644 --- a/R/Simulations-class.R +++ b/R/Simulations-class.R @@ -1,5 +1,6 @@ #' @include helpers.R #' @include Data-class.R +#' @include Simulations-validity.R #' @include CrmPackClass-class.R NULL @@ -53,23 +54,7 @@ NULL seed = 1L ), contains = "CrmPackClass", - validity = - function(object) { - o <- Validate() - - nSims <- length(object@data) - - o$check( - all(sapply(object@data, is, "Data")), - "all data elements must be Data objects" - ) - o$check( - identical(length(object@doses), nSims), - "doses must have same length as the data list" - ) - - o$result() - } + validity = v_general_simulations ) ## constructor ---- @@ -102,12 +87,13 @@ GeneralSimulations <- function(data, #' @description `r lifecycle::badge("stable")` #' #' This class captures the trial simulations from model based designs. -#' Additional slots `fit` and `stop_reasons` compared to the general class -#' [`GeneralSimulations`]. +#' Additional slots `fit`, `stop_reasons`, `stop_report`,`additional_stats` compared to +#' the general class [`GeneralSimulations`]. #' #' @slot fit (`list`)\cr final fits #' @slot stop_reasons (`list`)\cr stopping reasons for each simulation run #' @slot stop_report matrix of stopping rule outcomes +#' @slot additional_stats list of additional statistical summary #' @aliases Simulations #' @export .Simulations <- @@ -116,7 +102,8 @@ GeneralSimulations <- function(data, slots = c( fit = "list", stop_report = "matrix", - stop_reasons = "list" + stop_reasons = "list", + additional_stats = "list" ), prototype = prototype( fit = @@ -126,36 +113,12 @@ GeneralSimulations <- function(data, ), stop_report = matrix(TRUE, nrow = 2), stop_reasons = - list("A", "A") + list("A", "A"), + additional_stats = + list(a = 1, b = 1) ), contains = "GeneralSimulations", - validity = - function(object) { - o <- Validate() - - nSims <- length(object@data) - - o$check( - identical(length(object@fit), nSims), - "fit must have same length as data" - ) - o$check( - identical(length(object@stop_reasons), nSims), - "stop_reasons must have same length as data" - ) - - o$check( - checkmate::test_matrix(object@stop_report, - mode = "logical", - nrows = nSims, - min.cols = 1, - any.missing = FALSE - ), - "stop_report must be a matrix of mode logical in which the number of rows equals the number of simulations - and which must not contain any missing values" - ) - o$result() - } + validity = v_simulations ) ## constructor ---- @@ -165,6 +128,7 @@ GeneralSimulations <- function(data, #' @param fit (`list`)\cr see slot definition. #' @param stop_reasons (`list`)\cr see slot definition. #' @param stop_report see [`Simulations`] +#' @param additional_stats (`list`)\cr see slot definition. #' @param \dots additional parameters from [`GeneralSimulations`] #' #' @example examples/Simulations-class-Simulations.R @@ -172,12 +136,14 @@ GeneralSimulations <- function(data, Simulations <- function(fit, stop_reasons, stop_report, + additional_stats, ...) { start <- GeneralSimulations(...) .Simulations(start, fit = fit, stop_report = stop_report, - stop_reasons = stop_reasons + stop_reasons = stop_reasons, + additional_stats = additional_stats ) } @@ -217,27 +183,7 @@ Simulations <- function(fit, ) ), contains = "Simulations", - validity = - function(object) { - o <- Validate() - - nSims <- length(object@data) - - o$check( - identical(length(object@fit_biomarker), nSims), - "fit_biomarker list has to have same length as data" - ) - o$check( - identical(length(object@rho_est), nSims), - "rho_est vector has to have same length as data" - ) - o$check( - identical(length(object@sigma2w_est), nSims), - "sigma2w_est has to have same length as data" - ) - - o$result() - } + validity = v_dual_simulations ) @@ -320,6 +266,7 @@ DualSimulations <- function(rho_est, ##' initialization function is provided for this class. ##' ##' @slot stop_report matrix of stopping rule outcomes +##' @slot additional_stats list of additional statistical summary ##' @slot fitAtDoseMostSelected fitted toxicity rate at dose most often selected ##' @slot meanFit list with the average, lower (2.5%) and upper (97.5%) ##' quantiles of the mean fitted toxicity at each dose level @@ -332,6 +279,7 @@ DualSimulations <- function(rho_est, representation( stop_report = "matrix", fitAtDoseMostSelected = "numeric", + additional_stats = "list", meanFit = "list" ), contains = "GeneralSimulationsSummary" @@ -427,18 +375,7 @@ DualSimulations <- function(rho_est, list("A", "A") ), contains = "GeneralSimulations", - validity = - function(object) { - o <- Validate() - - nSims <- length(object@data) - o$check( - identical(length(object@stopReasons), nSims), - "stopReasons must have same length as data" - ) - - o$result() - } + validity = v_pseudo_simulations ) validObject(.PseudoSimulations()) @@ -541,16 +478,7 @@ PseudoSimulations <- function(fit, sigma2est = c(0.001, 0.002) ), contains = "PseudoSimulations", - validity = - function(object) { - o <- Validate() - nSims <- length(object@data) - o$check( - identical(length(object@sigma2est), nSims), - "sigma2est has to have same length as data" - ) - o$result() - } + validity = v_pseudo_dual_simulations ) validObject(.PseudoDualSimulations()) @@ -612,16 +540,7 @@ PseudoDualSimulations <- function(fitEff, representation(sigma2betaWest = "numeric"), prototype(sigma2betaWest = c(0.001, 0.002)), contains = "PseudoDualSimulations", - validity = - function(object) { - o <- Validate() - nSims <- length(object@data) - o$check( - identical(length(object@sigma2betaWest), nSims), - "sigma2betaWest has to have same length as data" - ) - o$result() - } + validity = v_pseudo_dual_flex_simulations ) validObject(.PseudoDualFlexiSimulations()) @@ -787,19 +706,7 @@ PseudoDualFlexiSimulations <- function(sigma2betaWest, representation(trialduration = "numeric"), prototype(trialduration = rep(0, 2)), contains = "Simulations", - validity = - function(object) { - o <- Validate() - - nSims <- length(object@data) - - o$check( - identical(length(object@trialduration), nSims), - "trialduration vector has to have same length as data" - ) - - o$result() - } + validity = v_da_simulations ) validObject(.DASimulations()) diff --git a/R/Simulations-methods.R b/R/Simulations-methods.R index 41f3782b0..71edf2cec 100644 --- a/R/Simulations-methods.R +++ b/R/Simulations-methods.R @@ -635,6 +635,7 @@ setMethod("summary", ret <- .SimulationsSummary( start, stop_report = object@stop_report, + additional_stats = object@additional_stats, fitAtDoseMostSelected = fitAtDoseMostSelected, meanFit = meanFit ) @@ -643,7 +644,6 @@ setMethod("summary", } ) - ##' Summarize the dual-endpoint design simulations, relative to given true ##' dose-toxicity and dose-biomarker curves ##' @@ -978,14 +978,23 @@ setMethod("show", ) - - ## add one reporting line r$report( "fitAtDoseMostSelected", "Fitted toxicity rate at dose most often selected" ) + # Report results of additional statistics summary + + if (length(list()) > 0) { + summary_stat_op <- unlist(object@additional_stats) + + cat( + "Results of Additional Statistical Calculation : \n", + paste(names(summary_stat_op), ":", round(summary_stat_op), "\n") + ) + } + # Report individual stopping rules with non- labels. diff --git a/R/Simulations-validity.R b/R/Simulations-validity.R new file mode 100644 index 000000000..5980d9349 --- /dev/null +++ b/R/Simulations-validity.R @@ -0,0 +1,169 @@ +# GeneralSimulations ---- + +#' Internal Helper Functions for Validation of [`GeneralSimulations`] Objects +#' +#' @description `r lifecycle::badge("stable")` +#' +#' These functions are only used internally to validate the format of an input +#' [`GeneralSimulations`] or inherited classes and therefore not exported. +#' +#' @name v_general_simulations +#' @param object (`GeneralSimulations`)\cr object to validate. +#' @return A `character` vector with the validation failure messages, +#' or `TRUE` in case validation passes. +NULL + +#' @describeIn v_general_simulations validates that the [`GeneralSimulations`] object +#' contains valid `data` object and valid `dose` simulations. + +v_general_simulations <- function(object) { + v <- Validate() + + nSims <- length(object@data) + + v$check( + all(sapply(object@data, is, "Data")), + "all data elements must be Data objects" + ) + v$check( + identical(length(object@doses), nSims), + "doses must have same length as the data list" + ) + + v$result() +} + +#' @describeIn v_general_simulations validates that the [`Simulations`] object +#' contains valid object `fit`, `stop_reasons`, `stop_report`, and +#' `additional_stats` compared to the general class [`GeneralSimulations`]. +#' +v_simulations <- function(object) { + v <- Validate() + + nSims <- length(object@data) + + v$check( + identical(length(object@fit), nSims), + "fit must have same length as data" + ) + v$check( + identical(length(object@stop_reasons), nSims), + "stop_reasons must have same length as data" + ) + + v$check( + checkmate::test_matrix(object@stop_report, + mode = "logical", + nrows = nSims, + min.cols = 1, + any.missing = FALSE + ), + "stop_report must be a matrix of mode logical in which the number of rows + equals the number of simulations and which must not contain any missing values" + ) + + v$result() +} + +#' @describeIn v_general_simulations validates that the [`DualSimulations`] object and +#' capture the dose-biomarker `fits`, and the `sigma2W` and `rho` estimates. +#' +v_dual_simulations <- function(object) { + v <- Validate() + + nSims <- length(object@data) + + v$check( + identical(length(object@fit_biomarker), nSims), + "fit_biomarker list has to have same length as data" + ) + v$check( + identical(length(object@rho_est), nSims), + "rho_est vector has to have same length as data" + ) + v$check( + identical(length(object@sigma2w_est), nSims), + "sigma2w_est has to have same length as data" + ) + + v$result() +} + +# PseudoSimulations ---- + +#' Internal Helper Functions for Validation of [`PseudoSimulations`] Objects +#' +#' @description `r lifecycle::badge("stable")` +#' +#' These functions are only used internally to validate the format of an input +#' [`PseudoSimulations`] or inherited classes and therefore not exported. +#' +#' @name v_pseudo_simulations +#' @param object (`PseudoSimulations`)\cr object to validate. +#' @return A `character` vector with the validation failure messages, +#' or `TRUE` in case validation passes. +NULL + +#' @describeIn v_pseudo_simulations validates that the [`PseudoSimulations`] object +#' contains valid `fit`, `FinalTDtargetEndOfTrialEstimates` , +#' `FinalTDtargetDuringTrialAtDoseGrid`,`FinalTDtargetEndOfTrialAtDoseGrid` , +#' `FinalTDEOTCIs`, `FinalTDEOTRatios`, `FinalCIs`, `FinalRatios`, +#' object and valid `stopReasons` simulations. + +v_pseudo_simulations <- function(object) { + v <- Validate() + + nSims <- length(object@data) + v$check( + identical(length(object@stopReasons), nSims), + "stopReasons must have same length as data" + ) + + v$result() +} + +#' @describeIn v_pseudo_simulations validates that the [`PseudoDualSimulations`] object +#' contains valid `fitEff`, `FinalGstarEstimates` , `FinalGstarAtDoseGrid`, +#' `FinalGstarCIs` , `FinalGstarRatios`, `FinalOptimalDose`, `FinalOptimalDoseAtDoseGrid` +#' object and valid `sigma2est` simulations. + +v_pseudo_dual_simulations <- function(object) { + v <- Validate() + nSims <- length(object@data) + v$check( + identical(length(object@sigma2est), nSims), + "sigma2est has to have same length as data" + ) + v$result() +} + +#' @describeIn v_pseudo_simulations validates that the [`PseudoDualFlexiSimulations`] +#' object contains valid `sigma2betaWest` vector of the final posterior mean +#' sigma2betaW estimates.`FinalGstarEstimates` , `FinalGstarAtDoseGrid`, +#' +v_pseudo_dual_flex_simulations <- function(object) { + v <- Validate() + nSims <- length(object@data) + v$check( + identical(length(object@sigma2betaWest), nSims), + "sigma2betaWest has to have same length as data" + ) + v$result() +} + +#' @describeIn v_general_simulations validates that the [`DASimulations`] object +#' contains valid `trialduration` the vector of trial duration values for all +#' simulations. + +v_da_simulations <- function(object) { + v <- Validate() + + nSims <- length(object@data) + + v$check( + identical(length(object@trialduration), nSims), + "trialduration vector has to have same length as data" + ) + + v$result() +} diff --git a/_pkgdown.yaml b/_pkgdown.yaml index 9ec53f831..8405ca0e2 100644 --- a/_pkgdown.yaml +++ b/_pkgdown.yaml @@ -235,6 +235,8 @@ reference: - v_safety_window_size - v_safety_window_const - v_rule_design + - v_general_simulations + - v_pseudo_simulations - title: Custom Checkmate Assertions contents: - assert_probabilities diff --git a/examples/Simulations-class-DualSimulations.R b/examples/Simulations-class-DualSimulations.R index 236f72c4d..3b903418f 100644 --- a/examples/Simulations-class-DualSimulations.R +++ b/examples/Simulations-class-DualSimulations.R @@ -27,6 +27,8 @@ stop_report <- matrix(c(TRUE, FALSE), nrow = 2) stop_reasons <- list("A", "B") +additional_stats <- list(a = 1, b = 1) + dual_simulations_obj <- DualSimulations( rho_est = c(0.25, 0.35), sigma2w_est = c(0.15, 0.25), @@ -34,6 +36,7 @@ dual_simulations_obj <- DualSimulations( fit = fit, stop_report = stop_report, stop_reasons = stop_reasons, + additional_stats = additional_stats, data = data_list, doses = doses, seed = seed diff --git a/examples/Simulations-class-Simulations.R b/examples/Simulations-class-Simulations.R index c2d9e7dc3..08af7aeb0 100644 --- a/examples/Simulations-class-Simulations.R +++ b/examples/Simulations-class-Simulations.R @@ -28,11 +28,13 @@ stop_report <- matrix(c(TRUE, FALSE), nrow = 2) stop_reasons <- list("A", "B") +additional_stats <- list(a = 1, b = 1) simulations <- Simulations( fit = fit, stop_report = stop_report, stop_reasons = stop_reasons, + additional_stats = additional_stats, data, doses, seed diff --git a/examples/Simulations-method-summary.R b/examples/Simulations-method-summary.R index 5982f504d..40c0834f4 100644 --- a/examples/Simulations-method-summary.R +++ b/examples/Simulations-method-summary.R @@ -74,7 +74,12 @@ time <- system.time(mySims <- simulate(design, nsim = 1, seed = 819, mcmcOptions = options, - parallel = FALSE + parallel = FALSE, + derive = list( + max_mtd = max, + mean_mtd = mean, + median_mtd = median + ), ))[3] # Summarize the Results of the Simulations diff --git a/man/DualSimulations-class.Rd b/man/DualSimulations-class.Rd index a1d11448c..d63885195 100644 --- a/man/DualSimulations-class.Rd +++ b/man/DualSimulations-class.Rd @@ -66,6 +66,8 @@ stop_report <- matrix(c(TRUE, FALSE), nrow = 2) stop_reasons <- list("A", "B") +additional_stats <- list(a = 1, b = 1) + dual_simulations_obj <- DualSimulations( rho_est = c(0.25, 0.35), sigma2w_est = c(0.15, 0.25), @@ -73,6 +75,7 @@ dual_simulations_obj <- DualSimulations( fit = fit, stop_report = stop_report, stop_reasons = stop_reasons, + additional_stats = additional_stats, data = data_list, doses = doses, seed = seed diff --git a/man/Simulations-class.Rd b/man/Simulations-class.Rd index e79e064e5..91cff7b2b 100644 --- a/man/Simulations-class.Rd +++ b/man/Simulations-class.Rd @@ -7,7 +7,7 @@ \alias{Simulations} \title{\code{Simulations}} \usage{ -Simulations(fit, stop_reasons, stop_report, ...) +Simulations(fit, stop_reasons, stop_report, additional_stats, ...) } \arguments{ \item{fit}{(\code{list})\cr see slot definition.} @@ -16,14 +16,16 @@ Simulations(fit, stop_reasons, stop_report, ...) \item{stop_report}{see \code{\link{Simulations}}} +\item{additional_stats}{(\code{list})\cr see slot definition.} + \item{\dots}{additional parameters from \code{\link{GeneralSimulations}}} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} This class captures the trial simulations from model based designs. -Additional slots \code{fit} and \code{stop_reasons} compared to the general class -\code{\link{GeneralSimulations}}. +Additional slots \code{fit}, \code{stop_reasons}, \code{stop_report},\code{additional_stats} compared to +the general class \code{\link{GeneralSimulations}}. } \section{Slots}{ @@ -33,6 +35,8 @@ Additional slots \code{fit} and \code{stop_reasons} compared to the general clas \item{\code{stop_reasons}}{(\code{list})\cr stopping reasons for each simulation run} \item{\code{stop_report}}{matrix of stopping rule outcomes} + +\item{\code{additional_stats}}{list of additional statistical summary} }} \examples{ @@ -66,11 +70,13 @@ stop_report <- matrix(c(TRUE, FALSE), nrow = 2) stop_reasons <- list("A", "B") +additional_stats <- list(a = 1, b = 1) simulations <- Simulations( fit = fit, stop_report = stop_report, stop_reasons = stop_reasons, + additional_stats = additional_stats, data, doses, seed diff --git a/man/SimulationsSummary-class.Rd b/man/SimulationsSummary-class.Rd index 47b7afeea..187a68a53 100644 --- a/man/SimulationsSummary-class.Rd +++ b/man/SimulationsSummary-class.Rd @@ -19,6 +19,8 @@ initialization function is provided for this class. \describe{ \item{\code{stop_report}}{matrix of stopping rule outcomes} +\item{\code{additional_stats}}{list of additional statistical summary} + \item{\code{fitAtDoseMostSelected}}{fitted toxicity rate at dose most often selected} \item{\code{meanFit}}{list with the average, lower (2.5\%) and upper (97.5\%) diff --git a/man/simulate-DADesign-method.Rd b/man/simulate-DADesign-method.Rd index 138175aff..c81112674 100644 --- a/man/simulate-DADesign-method.Rd +++ b/man/simulate-DADesign-method.Rd @@ -17,7 +17,8 @@ mcmcOptions = McmcOptions(), DA = TRUE, parallel = FALSE, - nCores = min(parallel::detectCores(), 5L), + nCores = min(parallel::detectCores(), 5), + derive = list(), ... ) } @@ -66,6 +67,10 @@ clusters of the computer? (not default)} \item{nCores}{how many cores should be used for parallel computing? Defaults to the number of cores on the machine (maximum 5)} +\item{derive}{a named list of functions which derives statistics, based on the +vector of posterior MTD samples. Each list element must therefore accept +one and only one argument, which is a numeric vector, and return a number.} + \item{\dots}{not used} } \value{ diff --git a/man/simulate-Design-method.Rd b/man/simulate-Design-method.Rd index 7bf60e08e..7ae3261f0 100644 --- a/man/simulate-Design-method.Rd +++ b/man/simulate-Design-method.Rd @@ -13,7 +13,8 @@ firstSeparate = FALSE, mcmcOptions = McmcOptions(), parallel = FALSE, - nCores = min(parallel::detectCores(), 5L), + nCores = min(parallel::detectCores(), 5), + derive = list(), ... ) } @@ -51,6 +52,10 @@ clusters of the computer? (not default)} \item{nCores}{how many cores should be used for parallel computing? Defaults to the number of cores on the machine, maximum 5.} +\item{derive}{a named list of functions which derives statistics, based on the +vector of posterior MTD samples. Each list element must therefore accept +one and only one argument, which is a numeric vector, and return a number.} + \item{\dots}{not used} } \value{ diff --git a/man/simulate-DualDesign-method.Rd b/man/simulate-DualDesign-method.Rd index 7fd87e696..4de120c6e 100644 --- a/man/simulate-DualDesign-method.Rd +++ b/man/simulate-DualDesign-method.Rd @@ -16,7 +16,8 @@ firstSeparate = FALSE, mcmcOptions = McmcOptions(), parallel = FALSE, - nCores = min(parallel::detectCores(), 5L), + nCores = min(parallel::detectCores(), 5), + derive = list(), ... ) } @@ -60,6 +61,10 @@ clusters of the computer? (not default)} \item{nCores}{how many cores should be used for parallel computing? Defaults to the number of cores on the machine, maximum 5.} +\item{derive}{a named list of functions which derives statistics, based on the +vector of posterior MTD samples. Each list element must therefore accept +one and only one argument, which is a numeric vector, and return a number.} + \item{\dots}{not used} } \value{ diff --git a/man/summary-Simulations-method.Rd b/man/summary-Simulations-method.Rd index 47bd83526..200ace395 100644 --- a/man/summary-Simulations-method.Rd +++ b/man/summary-Simulations-method.Rd @@ -101,7 +101,12 @@ time <- system.time(mySims <- simulate(design, nsim = 1, seed = 819, mcmcOptions = options, - parallel = FALSE + parallel = FALSE, + derive = list( + max_mtd = max, + mean_mtd = mean, + median_mtd = median + ), ))[3] # Summarize the Results of the Simulations diff --git a/man/v_general_simulations.Rd b/man/v_general_simulations.Rd new file mode 100644 index 000000000..caddef7d8 --- /dev/null +++ b/man/v_general_simulations.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Simulations-validity.R +\name{v_general_simulations} +\alias{v_general_simulations} +\alias{v_simulations} +\alias{v_dual_simulations} +\alias{v_da_simulations} +\title{Internal Helper Functions for Validation of \code{\link{GeneralSimulations}} Objects} +\usage{ +v_general_simulations(object) + +v_simulations(object) + +v_dual_simulations(object) + +v_da_simulations(object) +} +\arguments{ +\item{object}{(\code{GeneralSimulations})\cr object to validate.} +} +\value{ +A \code{character} vector with the validation failure messages, +or \code{TRUE} in case validation passes. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +These functions are only used internally to validate the format of an input +\code{\link{GeneralSimulations}} or inherited classes and therefore not exported. +} +\section{Functions}{ +\itemize{ +\item \code{v_general_simulations()}: validates that the \code{\link{GeneralSimulations}} object +contains valid \code{data} object and valid \code{dose} simulations. + +\item \code{v_simulations()}: validates that the \code{\link{Simulations}} object +contains valid object \code{fit}, \code{stop_reasons}, \code{stop_report}, and +\code{additional_stats} compared to the general class \code{\link{GeneralSimulations}}. + +\item \code{v_dual_simulations()}: validates that the \code{\link{DualSimulations}} object and +capture the dose-biomarker \code{fits}, and the \code{sigma2W} and \code{rho} estimates. + +\item \code{v_da_simulations()}: validates that the \code{\link{DASimulations}} object +contains valid \code{trialduration} the vector of trial duration values for all +simulations. + +}} diff --git a/man/v_pseudo_simulations.Rd b/man/v_pseudo_simulations.Rd new file mode 100644 index 000000000..fa5bba1b4 --- /dev/null +++ b/man/v_pseudo_simulations.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Simulations-validity.R +\name{v_pseudo_simulations} +\alias{v_pseudo_simulations} +\alias{v_pseudo_dual_simulations} +\alias{v_pseudo_dual_flex_simulations} +\title{Internal Helper Functions for Validation of \code{\link{PseudoSimulations}} Objects} +\usage{ +v_pseudo_simulations(object) + +v_pseudo_dual_simulations(object) + +v_pseudo_dual_flex_simulations(object) +} +\arguments{ +\item{object}{(\code{PseudoSimulations})\cr object to validate.} +} +\value{ +A \code{character} vector with the validation failure messages, +or \code{TRUE} in case validation passes. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +These functions are only used internally to validate the format of an input +\code{\link{PseudoSimulations}} or inherited classes and therefore not exported. +} +\section{Functions}{ +\itemize{ +\item \code{v_pseudo_simulations()}: validates that the \code{\link{PseudoSimulations}} object +contains valid \code{fit}, \code{FinalTDtargetEndOfTrialEstimates} , +\code{FinalTDtargetDuringTrialAtDoseGrid},\code{FinalTDtargetEndOfTrialAtDoseGrid} , +\code{FinalTDEOTCIs}, \code{FinalTDEOTRatios}, \code{FinalCIs}, \code{FinalRatios}, +object and valid \code{stopReasons} simulations. + +\item \code{v_pseudo_dual_simulations()}: validates that the \code{\link{PseudoDualSimulations}} object +contains valid \code{fitEff}, \code{FinalGstarEstimates} , \code{FinalGstarAtDoseGrid}, +\code{FinalGstarCIs} , \code{FinalGstarRatios}, \code{FinalOptimalDose}, \code{FinalOptimalDoseAtDoseGrid} +object and valid \code{sigma2est} simulations. + +\item \code{v_pseudo_dual_flex_simulations()}: validates that the \code{\link{PseudoDualFlexiSimulations}} +object contains valid \code{sigma2betaWest} vector of the final posterior mean +sigma2betaW estimates.\code{FinalGstarEstimates} , \code{FinalGstarAtDoseGrid}, + +}} diff --git a/tests/testthat/test-Design-methods.R b/tests/testthat/test-Design-methods.R index 25d02705f..bb77682e1 100644 --- a/tests/testthat/test-Design-methods.R +++ b/tests/testthat/test-Design-methods.R @@ -1,5 +1,39 @@ # simulate ---- +test_that("Test if simulate generate the expected output.", { + data <- h_get_data(placebo = FALSE) + model <- h_get_logistic_normal() + increments <- h_increments_relative() + next_best <- h_next_best_ncrm() + size <- CohortSizeConst(size = 3) + + # Extreme truth function, which has constant probability 1 in dose grid range. + truth <- probFunction(model, alpha0 = 175, alpha1 = 5) + stop_rule <- StoppingMinPatients(nPatients = 5) + design <- Design( + model = model, + stopping = stop_rule, + increments = increments, + nextBest = next_best, + cohort_size = size, + data = data, + startingDose = 25 + ) + + my_options <- McmcOptions(burnin = 100, step = 2, samples = 5, rng_kind = "Mersenne-Twister", rng_seed = 3) + + sim <- simulate( + design, + nsim = 1, + truth = truth, + seed = 819, + mcmcOptions = my_options + ) + + expect_snapshot(sim) +}) + + ## NextBestInfTheory ---- test_that("NextBestInfTheory produces consistent results for empty data", { @@ -255,7 +289,7 @@ test_that("simulate for DesignGrouped works when first patient is dosed separate truth = my_truth, firstSeparate = TRUE, combo_truth = my_combo_truth, - mcmcOptions = h_get_mcmc_options() + mcmcOptions = h_get_mcmc_options(), )) expect_list(result) diff --git a/tests/testthat/test-Simulations-class.R b/tests/testthat/test-Simulations-class.R index cccf2e749..ceac7f0e4 100644 --- a/tests/testthat/test-Simulations-class.R +++ b/tests/testthat/test-Simulations-class.R @@ -63,6 +63,8 @@ test_that("Simulations object can be created with the user constructor", { stop_report <- matrix(c(TRUE, FALSE), nrow = 2) + additional_stats <- list(a = 1, b = 1) + data <- list( Data( x = 1:2, @@ -89,6 +91,7 @@ test_that("Simulations object can be created with the user constructor", { fit = fit, stop_reasons = stop_reasons, stop_report = stop_report, + additional_stats = additional_stats, data, doses, seed @@ -103,7 +106,7 @@ test_that("Simulations object can be created with the user constructor", { test_that("Simulations user constructor arguments names are as expected", { expect_function( Simulations, - args = c("fit", "stop_reasons", "stop_report", "..."), + args = c("fit", "stop_reasons", "stop_report", "additional_stats", "..."), ordered = TRUE ) }) @@ -148,6 +151,8 @@ test_that("DualSimulations object can be created with the user constructor", { stop_reasons <- list("A", "B") + additional_stats <- list(a = 1, b = 1) + result <- expect_silent( DualSimulations( rho_est = rho_est, @@ -156,6 +161,7 @@ test_that("DualSimulations object can be created with the user constructor", { fit = fit, stop_report = stop_report, stop_reasons = stop_reasons, + additional_stats = additional_stats, data = data_list, doses = doses, seed = seed