Implement NextBestList and subclasses

DESCRIPTION

@@ -54,6 +54,7 @@ Imports:
     mvtnorm,
     parallel,
     parallelly,
+    patchwork,
     rjags,
     rlang,
     survival,

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.

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

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

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

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

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)