diff --git a/DESCRIPTION b/DESCRIPTION index 218073fdb..5720969dd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -54,6 +54,7 @@ Imports: mvtnorm, parallel, parallelly, + patchwork, rjags, rlang, survival, diff --git a/NEWS.md b/NEWS.md index bee6a9ca2..557708de6 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # Version 2.0.0.9000 * **Note: This release (1.0 -> 2.0) signifies a major breaking revamp of the package.** Users are advised to carefully review the release notes and documentation for detailed information on the changes and any necessary updates to their existing code. +* Added `NextBestList`, `NextBestMin` and `NextBestMax` classes * Implemented `knit_print` methods for almost all `crmPack` classes to improve rendering in Markdown and Quarto documents. See the vignette for more details. * Provided basic support for ordinal CRM models. See the vignette for more details. * Implemented `broom`-like `tidy` methods for all concrete `crmPack` classes. See the vignette for more details. diff --git a/R/Rules-class.R b/R/Rules-class.R index dbdc63a5c..366f4a7d8 100644 --- a/R/Rules-class.R +++ b/R/Rules-class.R @@ -979,6 +979,169 @@ NextBestOrdinal <- function(grade, rule) { ) } +# NextBestList ---- + +## class ---- + +#' `NextBestList` +#' +#' @description `r lifecycle::badge("experimental")` +#' +#' [`NextBestList`] is the class for selecting the overall next best dose by +#' applying a function to a `list` of `NextBest` rules. +#' +#' @slot summary (`function`)\cr the summary function that selects the overall +#' next best dose +#' @slot rules (`list`)\cr the list of rules to which `summary` will be applied +#' @aliases NextBestList +#' @export +#' +.NextBestList <- setClass( + Class = "NextBestList", + slots = c(summary = "function", rules = "list"), + contains = "NextBest", + validity = v_next_best_list +) + +## constructor ---- + +#' @rdname NextBestList-class +#' +#' @param summary (`function`)\cr see slot definition. +#' @param rules (`list`)\cr see slot definition. +#' @export +#' @example examples/Rules-class-NextBestList.R +#' +NextBestList <- function(summary, rules) { + .NextBestList(summary = summary, rules = rules) +} + +## default constructor ---- + +#' @rdname NextBestList-class +#' @note Typically, end users will not use the `.DefaultNextBestList()` function. +#' @export +.DefaultNextBestList <- function() { + NextBestList( + summary = min, + rules = list( + NextBestMTD( + 0.25, + function(mtd_samples) { + quantile(mtd_samples, probs = 0.25) + } + ), + NextBestMinDist(target = 0.33) + ) + ) +} + +## class ---- + +#' `NextBestMin` +#' +#' @description `r lifecycle::badge("experimental")` +#' +#' [`NextBestMin`] is the class for selecting the overall next best dose as the +#' minimum of next best doses derived from `list` of `NextBest` rules. +#' +#' @inheritParams NextBestList +#' @aliases NextBestMin +#' @export +#' +.NextBestMin <- setClass( + Class = "NextBestMin", + contains = "NextBestList", + prototype = prototype( + summary = min, + rules = list() + ), + validity = v_next_best_list +) + +## constructor ---- + +#' @rdname NextBestMin-class +#' +#' @export +#' @example examples/Rules-class-NextBestList.R +#' +NextBestMin <- function(rules) { + .NextBestMin(rules = rules) +} + +## default constructor ---- + +#' @rdname NextBestMin-class +#' @note Typically, end users will not use the `.DefaultNextBestMin()` function. +#' @export +.DefaultNextBestMin <- function() { + NextBestMin( + rules = list( + NextBestMTD( + 0.25, + function(mtd_samples) { + quantile(mtd_samples, probs = 0.25) + } + ), + NextBestMinDist(target = 0.33) + ) + ) +} + +## class ---- + +#' `NextBestMax` +#' +#' @description `r lifecycle::badge("experimental")` +#' +#' [`NextBestMin`] is the class for selecting the overall next best dose as the +#' maximum of next best doses derived from `list` of `NextBest` rules. +#' +#' @inheritParams NextBestList +#' @aliases NextBestMax +#' @export +#' +.NextBestMax <- setClass( + Class = "NextBestMax", + contains = "NextBestList", + prototype = prototype( + summary = max, + rules = list() + ), + validity = v_next_best_list +) + +## constructor ---- + +#' @rdname NextBestMin-class +#' +#' @export +#' @example examples/Rules-class-NextBestList.R +#' +NextBestMax <- function(rules) { + .NextBestMax(rules = rules) +} + +## default constructor ---- + +#' @rdname NextBestMax-class +#' @note Typically, end users will not use the `.DefaultNextBestMax()` function. +#' @export +.DefaultNextBestMax <- function() { + NextBestMax( + rules = list( + NextBestMTD( + 0.25, + function(mtd_samples) { + quantile(mtd_samples, probs = 0.25) + } + ), + NextBestMinDist(target = 0.33) + ) + ) +} + # Increments ---- ## class ---- diff --git a/R/Rules-methods.R b/R/Rules-methods.R index 77a19fb1a..61dac227a 100644 --- a/R/Rules-methods.R +++ b/R/Rules-methods.R @@ -1418,6 +1418,55 @@ setMethod( } ) +## NextBestList ---- + +#' @describeIn nextBest find the next best dose defined by applying a summary +#' function to a `list` of `NextBest` rules. +#' +#' @aliases nextBest-NextBestList +#' +#' @export +#' @example examples/Rules-method-nextBest-NextBestList.R +#' +setMethod( + f = "nextBest", + signature = signature( + nextBest = "NextBestList", + doselimit = "numeric", + samples = "Samples", + model = "GeneralModel", + data = "Data" + ), + definition = function(nextBest, doselimit = Inf, samples, model, data, ...) { + # Apply the rules + nb_list <- lapply( + nextBest@rules, + nextBest, + doselimit = doselimit, + samples = samples, + model = model, + data = data, + ... + ) + + # Apply the rules + nb_list <- lapply( + nextBest@rules, + function(nb) nextBest(nb, doselimit, samples, model, data) + ) + + # Obtain the next best dose + recommedations <- sapply(nb_list, function(nb) nb$value) + next_dose <- nextBest@summary(recommedations) + + # Facet the plots + single_plots <- lapply(nb_list, function(nb) nb$plot) + plot <- patchwork::wrap_plots(single_plots) + + list(value = next_dose, plot = plot, singlePlots = single_plots) + } +) + # maxDose ---- ## generic ---- diff --git a/R/Rules-validity.R b/R/Rules-validity.R index ec79225f2..fa653bf38 100644 --- a/R/Rules-validity.R +++ b/R/Rules-validity.R @@ -218,6 +218,27 @@ v_next_best_prob_mtd_min_dist <- function(object) { v$result() } +#' @describeIn v_next_best validates that the [`NextBestList`] object +#' contains a valid `summary` function and `rules` objects. +v_next_best_list <- function(object) { + v <- Validate() + v$check( + test_function(object@summary), + "summary must be a function" + ) + v$check( + test_list(object@rules), + "rules must be a list" + ) + for (rule in object@rules) { + v$check( + test_class(rule, "NextBest"), + paste0("rules contains an object of class ", class(rule), ": only NextBest objects are permitted") + ) + } + v$result() +} + # Increments ---- #' Internal Helper Functions for Validation of [`Increments`] Objects diff --git a/examples/Rules-class-NextBestList.R b/examples/Rules-class-NextBestList.R new file mode 100644 index 000000000..48b6c7296 --- /dev/null +++ b/examples/Rules-class-NextBestList.R @@ -0,0 +1,36 @@ +my_next_best_median <- NextBestList( + summary = median, + rules = list( + NextBestMTD( + 0.25, + function(mtd_samples) { + quantile(mtd_samples, probs = 0.25) + } + ), + NextBestMinDist(target = 0.33) + ) +) + +my_next_best_max <- NextBestMax( + rules = list( + NextBestMTD( + 0.25, + function(mtd_samples) { + quantile(mtd_samples, probs = 0.25) + } + ), + NextBestMinDist(target = 0.33) + ) +) + +my_next_best_min <- NextBestMin( + rules = list( + NextBestMTD( + 0.25, + function(mtd_samples) { + quantile(mtd_samples, probs = 0.25) + } + ), + NextBestMinDist(target = 0.33) + ) +) diff --git a/examples/Rules-method-nextBest-NextBestList.R b/examples/Rules-method-nextBest-NextBestList.R new file mode 100644 index 000000000..29f7da991 --- /dev/null +++ b/examples/Rules-method-nextBest-NextBestList.R @@ -0,0 +1,26 @@ +data <- Data( + doseGrid = c(1, 3, 9, 18, 36, 54, 80, 100), + x = c(1, 1, 1, 3, 3, 3, 9, 9, 9), + y = c(rep(0, 8), 1), + cohort = rep(1L:3L, each = 3), + ID = 1L:9L +) + +model <- .DefaultLogisticLogNormal() +samples <- mcmc(data, model, .DefaultMcmcOptions()) + +next_best_mtd <- NextBestMTD( + 0.25, + function(mtd_samples) quantile(mtd_samples, probs = 0.25) +) + +next_best_min_dist <- .DefaultNextBestMinDist() + +nextBest(next_best_mtd, Inf, samples, model, data) +nextBest(next_best_min_dist, Inf, samples, model, data) + +next_best_min <- NextBestMin(list(next_best_mtd, next_best_min_dist)) +nextBest(next_best_min, Inf, samples, model, data) + +next_best_max <- NextBestMax(list(next_best_mtd, next_best_min_dist)) +nextBest(next_best_max, Inf, samples, model, data) diff --git a/tests/testthat/_snaps/Rules-methods/nextbest-nextbestdualendpoint-atgt-nodlim.svg b/tests/testthat/_snaps/Rules-methods/nextbest-nextbestdualendpoint-atgt-nodlim.svg index 42933dc63..718228d81 100644 --- a/tests/testthat/_snaps/Rules-methods/nextbest-nextbestdualendpoint-atgt-nodlim.svg +++ b/tests/testthat/_snaps/Rules-methods/nextbest-nextbestdualendpoint-atgt-nodlim.svg @@ -21,135 +21,135 @@ - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Target probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Target probability [%] - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Overdose probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Overdose probability [%] diff --git a/tests/testthat/_snaps/Rules-methods/nextbest-nextbestmax.svg b/tests/testthat/_snaps/Rules-methods/nextbest-nextbestmax.svg new file mode 100644 index 000000000..9783a2927 --- /dev/null +++ b/tests/testthat/_snaps/Rules-methods/nextbest-nextbestmax.svg @@ -0,0 +1,178 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Est + +Next + + +0.00 +0.01 +0.02 + + + + + + + + +0 +25 +50 +75 +100 +MTD +Posterior density + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Est + +Next + + +0.0 +0.2 +0.4 +0.6 + + + + + + + + + + + + +1 +100 +18 +3 +9 +54 +36 +80 +Dose +Posterior toxicity probability +nextBest-NextBestMax + + diff --git a/tests/testthat/_snaps/Rules-methods/nextbest-nextbestmin.svg b/tests/testthat/_snaps/Rules-methods/nextbest-nextbestmin.svg new file mode 100644 index 000000000..e5129b7f3 --- /dev/null +++ b/tests/testthat/_snaps/Rules-methods/nextbest-nextbestmin.svg @@ -0,0 +1,178 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Est + +Next + + +0.00 +0.01 +0.02 + + + + + + + + +0 +25 +50 +75 +100 +MTD +Posterior density + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Est + +Next + + +0.0 +0.2 +0.4 +0.6 + + + + + + + + + + + + +1 +100 +18 +3 +9 +54 +36 +80 +Dose +Posterior toxicity probability +nextBest-NextBestMin + + diff --git a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestdualendpoint-abstarget.svg b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestdualendpoint-abstarget.svg index ba2477f3c..ab1f56b98 100644 --- a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestdualendpoint-abstarget.svg +++ b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestdualendpoint-abstarget.svg @@ -21,136 +21,136 @@ - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Target probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Target probability [%] - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Overdose probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Overdose probability [%] diff --git a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestdualendpoint-emax.svg b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestdualendpoint-emax.svg index e4f66e0d4..9ba876288 100644 --- a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestdualendpoint-emax.svg +++ b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestdualendpoint-emax.svg @@ -21,136 +21,136 @@ - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Target probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Target probability [%] - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Overdose probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Overdose probability [%] diff --git a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestdualendpoint.svg b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestdualendpoint.svg index 77a4c7d28..567ca6ea7 100644 --- a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestdualendpoint.svg +++ b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestdualendpoint.svg @@ -21,136 +21,136 @@ - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Target probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Target probability [%] - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Overdose probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Overdose probability [%] diff --git a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm-dataparts-nodlim.svg b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm-dataparts-nodlim.svg index fcf460971..e6d0ab8a5 100644 --- a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm-dataparts-nodlim.svg +++ b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm-dataparts-nodlim.svg @@ -21,135 +21,135 @@ - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Target probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Target probability [%] - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Overdose probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Overdose probability [%] diff --git a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm-dataparts.svg b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm-dataparts.svg index 204f62d6b..f430c5a36 100644 --- a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm-dataparts.svg +++ b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm-dataparts.svg @@ -21,136 +21,136 @@ - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Target probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Target probability [%] - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Overdose probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Overdose probability [%] diff --git a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm-without-doselimit.svg b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm-without-doselimit.svg index fcf460971..e6d0ab8a5 100644 --- a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm-without-doselimit.svg +++ b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm-without-doselimit.svg @@ -21,135 +21,135 @@ - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Target probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Target probability [%] - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Overdose probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Overdose probability [%] diff --git a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm.svg b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm.svg index 204f62d6b..f430c5a36 100644 --- a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm.svg +++ b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrm.svg @@ -21,136 +21,136 @@ - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Target probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Target probability [%] - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Overdose probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Overdose probability [%] diff --git a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrmloss-with-losses-of-4.svg b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrmloss-with-losses-of-4.svg index 5608bde8e..f24489272 100644 --- a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrmloss-with-losses-of-4.svg +++ b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrmloss-with-losses-of-4.svg @@ -21,199 +21,199 @@ - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Target probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Target probability [%] - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Excessive probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Excessive probability [%] - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Unacceptable probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Unacceptable probability [%] @@ -226,60 +226,60 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0.0 -0.5 -1.0 -1.5 -2.0 - - - - - - - - -100 -200 -300 -Dose -Loss function +0.0 +0.5 +1.0 +1.5 +2.0 + + + + + + + + +100 +200 +300 +Dose +Loss function diff --git a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrmloss-without-doselimit.svg b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrmloss-without-doselimit.svg index 83bc1f3ab..d7aa948cf 100644 --- a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrmloss-without-doselimit.svg +++ b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrmloss-without-doselimit.svg @@ -21,135 +21,135 @@ - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Target probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Target probability [%] - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Overdose probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Overdose probability [%] @@ -162,60 +162,60 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0.0 -0.5 -1.0 -1.5 -2.0 - - - - - - - - -100 -200 -300 -Dose -Loss function +0.0 +0.5 +1.0 +1.5 +2.0 + + + + + + + + +100 +200 +300 +Dose +Loss function diff --git a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrmloss.svg b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrmloss.svg index 529aae3dc..05c3e5be7 100644 --- a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrmloss.svg +++ b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbestncrmloss.svg @@ -21,136 +21,136 @@ - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Target probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Target probability [%] - + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0 -25 -50 -75 -100 - - - - - - - - -100 -200 -300 -Dose -Overdose probability [%] +0 +25 +50 +75 +100 + + + + + + + + +100 +200 +300 +Dose +Overdose probability [%] @@ -163,60 +163,60 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -0.0 -0.5 -1.0 -1.5 -2.0 - - - - - - - - -100 -200 -300 -Dose -Loss function +0.0 +0.5 +1.0 +1.5 +2.0 + + + + + + + + +100 +200 +300 +Dose +Loss function diff --git a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbesttdsamples-nodoselim.svg b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbesttdsamples-nodoselim.svg index f6956bdc0..3653d735b 100644 --- a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbesttdsamples-nodoselim.svg +++ b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbesttdsamples-nodoselim.svg @@ -54,19 +54,19 @@ 300 TD Posterior density - - - - - - - - - -Max -Next -TD 45 Estimate -TD 40 Estimate + + + + + + + + + +Max +Next +TD 45 Estimate +TD 40 Estimate Plot of nextBest-NextBestTDsamples_nodoselim diff --git a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbesttdsamples.svg b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbesttdsamples.svg index 6827b18f2..86321db20 100644 --- a/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbesttdsamples.svg +++ b/tests/testthat/_snaps/Rules-methods/plot-of-nextbest-nextbesttdsamples.svg @@ -54,19 +54,19 @@ 300 TD Posterior density - - - - - - - - - -Max -Next -TD 45 Estimate -TD 40 Estimate + + + + + + + + + +Max +Next +TD 45 Estimate +TD 40 Estimate Plot of nextBest-NextBestTDsamples diff --git a/tests/testthat/test-Rules-methods.R b/tests/testthat/test-Rules-methods.R index 1d2f1af07..a204c8a04 100644 --- a/tests/testthat/test-Rules-methods.R +++ b/tests/testthat/test-Rules-methods.R @@ -910,6 +910,89 @@ test_that("nextBest-NextBestOrdinal works correctly", { expect_equal(actual$value, 50) }) +test_that("nextBest-NextBestMax works correctly", { + data <- Data( + doseGrid = c(1, 3, 9, 18, 36, 54, 80, 100), + x = c(1, 1, 1, 3, 3, 3, 9, 9, 9), + y = c(rep(0, 8), 1), + cohort = rep(1L:3L, each = 3), + ID = 1L:9L + ) + + model <- .DefaultLogisticLogNormal() + samples <- mcmc( + data, + model, + McmcOptions( + burnin = 250, + samples = 1000, + rng_kind = "Mersenne-Twister", + rng_seed = 123L + ) + ) + + next_best_mtd <- NextBestMTD( + 0.25, + function(mtd_samples) quantile(mtd_samples, probs = 0.25) + ) + + next_best_min_dist <- .DefaultNextBestMinDist() + + next_best_max <- NextBestMax(list(next_best_mtd, next_best_min_dist)) + actual <- nextBest(next_best_max, Inf, samples, model, data) + expect_equal(actual$value, 18L) + vdiffr::expect_doppelganger("nextBest-NextBestMax", actual$plot) +}) + +test_that("nextBest-NextBestMin works correctly", { + data <- Data( + doseGrid = c(1, 3, 9, 18, 36, 54, 80, 100), + x = c(1, 1, 1, 3, 3, 3, 9, 9, 9), + y = c(rep(0, 8), 1), + cohort = rep(1L:3L, each = 3), + ID = 1L:9L + ) + + model <- .DefaultLogisticLogNormal() + samples <- mcmc( + data, + model, + McmcOptions( + burnin = 250, + samples = 1000, + rng_kind = "Mersenne-Twister", + rng_seed = 123L + ) + ) + + next_best_mtd <- NextBestMTD( + 0.25, + function(mtd_samples) quantile(mtd_samples, probs = 0.25) + ) + + next_best_min_dist <- .DefaultNextBestMinDist() + + next_best_max <- NextBestMin(list(next_best_mtd, next_best_min_dist)) + actual <- nextBest(next_best_max, Inf, samples, model, data) + expect_equal(actual$value, 9L) + vdiffr::expect_doppelganger("nextBest-NextBestMin", actual$plot) +}) + +test_that("NextBestList fails gracefully with bad input", { + expect_error( + NextBestList( + "notAFunction", + list(.DefaultNextBestMTD(), .DefaultNextBestMinDist()) + ) + ) + expect_error( + NextBestList( + mean, + list(.DefaultNextBestMTD(), .DefaultCohortSizeConst()) + ) + ) +}) + # maxDose ---- ## IncrementsRelative ----