diff --git a/.lintr b/.lintr
index 7049743a2..e1cd584ba 100644
--- a/.lintr
+++ b/.lintr
@@ -1,6 +1,7 @@
linters: linters_with_defaults(
line_length_linter = line_length_linter(120),
cyclocomp_linter = NULL,
+ indentation_linter = NULL,
object_usage_linter = NULL,
object_length_linter = NULL,
object_name_linter = object_name_linter(c("CamelCase", "camelCase", "snake_case"))
diff --git a/DESCRIPTION b/DESCRIPTION
index 4512b8c7b..11148090e 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -82,6 +82,7 @@ Collate:
'Data-validity.R'
'helpers.R'
'Data-class.R'
+ 'helpers_data.R'
'Data-methods.R'
'Rules-validity.R'
'Rules-class.R'
@@ -111,6 +112,7 @@ Collate:
'checkmate.R'
'crmPack-package.R'
'helpers_covr.R'
+ 'helpers_design.R'
'helpers_model.R'
'logger.R'
'utils-pipe.R'
diff --git a/NAMESPACE b/NAMESPACE
index 5fc20e077..b6e7c10b3 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -19,6 +19,7 @@ export(.DataDA)
export(.DataDual)
export(.DataGrouped)
export(.DataMixture)
+export(.DataOrdinal)
export(.DataParts)
export(.DefaultCohortSizeConst)
export(.DefaultCohortSizeDLT)
@@ -28,6 +29,7 @@ export(.DefaultCohortSizeParts)
export(.DefaultCohortSizeRange)
export(.DefaultDALogisticLogNormal)
export(.DefaultDataGrouped)
+export(.DefaultDesignGrouped)
export(.DefaultDualEndpoint)
export(.DefaultDualEndpointBeta)
export(.DefaultDualEndpointEmax)
@@ -86,6 +88,7 @@ export(.DefaultStoppingTargetBiomarker)
export(.DefaultStoppingTargetProb)
export(.DefaultTITELogisticLogNormal)
export(.Design)
+export(.DesignGrouped)
export(.DualDesign)
export(.DualEndpoint)
export(.DualEndpointBeta)
@@ -187,8 +190,10 @@ export(DataDA)
export(DataDual)
export(DataGrouped)
export(DataMixture)
+export(DataOrdinal)
export(DataParts)
export(Design)
+export(DesignGrouped)
export(DualDesign)
export(DualEndpoint)
export(DualEndpointBeta)
@@ -348,7 +353,7 @@ export(prob)
export(probFunction)
export(probit)
export(saveSample)
-export(setSeed)
+export(set_seed)
export(size)
export(stopTrial)
export(test_length)
@@ -373,8 +378,10 @@ exportClasses(DataDA)
exportClasses(DataDual)
exportClasses(DataGrouped)
exportClasses(DataMixture)
+exportClasses(DataOrdinal)
exportClasses(DataParts)
exportClasses(Design)
+exportClasses(DesignGrouped)
exportClasses(DualDesign)
exportClasses(DualEndpoint)
exportClasses(DualEndpointBeta)
@@ -532,10 +539,8 @@ importFrom(kableExtra,kbl)
importFrom(lifecycle,badge)
importFrom(magrittr,"%>%")
importFrom(mvtnorm,rmvnorm)
-importFrom(parallel,clusterApply)
importFrom(parallel,detectCores)
importFrom(parallel,makeCluster)
-importFrom(parallel,stopCluster)
importFrom(parallelly,availableCores)
importFrom(rjags,jags.model)
importFrom(rjags,jags.samples)
diff --git a/NEWS.md b/NEWS.md
index 9f8cdcaf7..e29ebb17b 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,5 +1,5 @@
# Version 1.0.9000.9133
-* Added new `DataGrouped` class to support simultaneous dose escalation with monotherapy and combination therapy.
+* Added new `DataGrouped` and `DesignGrouped` classes with corresponding model `LogisticLogNormalGrouped` to support simultaneous dose escalation with monotherapy and combination therapy arms.
* Created the `CrmPackClass` class as the ultimate ancestor of all other
`crmPack` classes to allow identification of crmPack classes and simpler
definition of generic methods.
diff --git a/R/Data-class.R b/R/Data-class.R
index 3fc92ea50..5d2ccce29 100644
--- a/R/Data-class.R
+++ b/R/Data-class.R
@@ -380,6 +380,105 @@ DataDA <- function(u = numeric(),
)
}
+# DataOrdinal ----
+
+## class ----
+
+#' `DataOrdinal`
+#'
+#' @description `r lifecycle::badge("experimental")`
+#'
+#' [`DataOrdinal`] is a class for ordinal toxicity data.
+#' It inherits from [`GeneralData`] and it describes toxicity responses on an
+#' ordinal rather than binary scale.
+#'
+#' @note This class has been implemented as a sibling of the existing `Data` class
+#' (rather than as a parent or child) to minimise the risk of unintended side
+#' effects on existing classes and methods.
+#'
+#' The default setting for the `yCategories` slot replicates the behaviour
+#' of the existing `Data` class.
+#'
+#' @aliases DataOrdinal
+#' @export
+.DataOrdinal <- setClass(
+ Class = "DataOrdinal",
+ contains = "GeneralData",
+ slots = c(
+ x = "numeric",
+ y = "integer",
+ doseGrid = "numeric",
+ nGrid = "integer",
+ xLevel = "integer",
+ yCategories = "integer",
+ placebo = "logical"
+ ),
+ prototype = prototype(
+ x = numeric(),
+ y = integer(),
+ doseGrid = numeric(),
+ nGrid = 0L,
+ xLevel = integer(),
+ yCategories = c("No DLT" = 0L, "DLT" = 1L),
+ placebo = FALSE
+ ),
+ validity = v_data_ordinal
+)
+
+## constructor ----
+
+#' @rdname DataOrdinal-class
+#' @param yCategories (named `integer`)\cr the names and codes for the
+#' toxicity categories used in the data. Category labels are taken from the
+#' names of the vector. The names of the vector must be unique and its values
+#' must be sorted and take the values 0, 1, 2, ...
+#' @inheritParams Data
+#' @inherit Data details note params
+#' @example examples/Data-class-DataOrdinal.R
+#' @export
+DataOrdinal <- function(x = numeric(),
+ y = integer(),
+ ID = integer(),
+ cohort = integer(),
+ doseGrid = numeric(),
+ placebo = FALSE,
+ yCategories = c("No DLT" = 0L, "DLT" = 1L),
+ ...) {
+ assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
+ assert_numeric(yCategories, any.missing = FALSE, unique = TRUE)
+ assert_character(names(yCategories), any.missing = FALSE, unique = TRUE)
+ assert_flag(placebo)
+
+ doseGrid <- as.numeric(sort(doseGrid))
+
+ if (length(ID) == 0 && length(x) > 0) {
+ message("Used default patient IDs!")
+ ID <- seq_along(x)
+ }
+
+ if (!placebo && length(cohort) == 0 && length(x) > 0) {
+ message("Used best guess cohort indices!")
+ # This is just assuming that consecutive patients
+ # in the data set are in the same cohort if they
+ # have the same dose. Note that this could be wrong,
+ # if two subsequent cohorts are at the same dose.
+ cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
+ }
+
+ .DataOrdinal(
+ x = as.numeric(x),
+ y = safeInteger(y),
+ ID = safeInteger(ID),
+ cohort = safeInteger(cohort),
+ doseGrid = doseGrid,
+ nObs = length(x),
+ nGrid = length(doseGrid),
+ xLevel = matchTolerance(x = x, table = doseGrid),
+ placebo = placebo,
+ yCategories = yCategories
+ )
+}
+
# DataGrouped ----
## class ----
@@ -408,8 +507,6 @@ DataDA <- function(u = numeric(),
validity = v_data_grouped
)
-## constructor ----
-
#' @rdname DataGrouped-class
#'
#' @param group (`factor` or `character`)\cr whether `mono` or `combo` was used.
diff --git a/R/Data-methods.R b/R/Data-methods.R
index 3fcd3de79..2f37a8834 100644
--- a/R/Data-methods.R
+++ b/R/Data-methods.R
@@ -1,3 +1,5 @@
+#' @include helpers_data.R
+
# plot ----
## Data ----
@@ -8,7 +10,30 @@
#'
#' A method that creates a plot for [`Data`] object.
#'
-#' @param x (`Data`)\cr object we want to plot.
+#' @return The [`ggplot2`] object.
+#'
+#' @aliases plot-Data
+#' @rdname plot-Data
+#' @export
+#' @example examples/Data-method-plot.R
+#'
+setMethod(
+ f = "plot",
+ signature = signature(x = "Data", y = "missing"),
+ definition = function(x, y, blind = FALSE, legend = TRUE, ...) {
+ assert_flag(blind)
+ assert_flag(legend)
+ h_plot_data_dataordinal(x, blind, legend, ...)
+ }
+)
+
+#' Plot Method for the [`DataOrdinal`] Class
+#'
+#' @description `r lifecycle::badge("experimental")`
+#'
+#' A method that creates a plot for [`DataOrdinal`] object.
+#'
+#' @param x (`DataOrdinal`)\cr object we want to plot.
#' @param y (`missing`)\cr missing object, for compatibility with the generic
#' function.
#' @param blind (`flag`)\cr indicates whether to blind the data.
@@ -16,62 +41,55 @@
#' as the active dose level in the corresponding cohort,
#' and DLTs are always assigned to the first subjects in a cohort.
#' @param legend (`flag`)\cr whether the legend should be added.
+#' @param tox_labels (`named list of character`)\cr the labels of the toxicity
+#' categories.
+#' @param tox_shapes (`names list of integers`)\cr the symbols used to identify
+#' the toxicity categories.
#' @param ... not used.
#'
+#' @note With more than 9 toxicity categories, toxicity symbols must be
+#' specified manually.\cr With more than 5 toxicity categories, toxicity labels
+#' must be specified manually.
+#'
#' @return The [`ggplot2`] object.
#'
-#' @aliases plot-Data
+#' @rdname plot-Data
#' @export
-#' @example examples/Data-method-plot.R
-#'
+#' @example examples/DataOrdinal-method-plot.R
setMethod(
f = "plot",
- signature = signature(x = "Data", y = "missing"),
- definition = function(x, y, blind = FALSE, legend = TRUE, ...) {
- assert_flag(blind)
- assert_flag(legend)
-
- if (x@nObs == 0L) {
- return()
- }
-
- df <- h_plot_data_df(x, blind, ...)
-
- p <- ggplot(df, aes(x = patient, y = dose)) +
- geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +
- scale_colour_manual(
- name = "Toxicity", values = c(Yes = "red", No = "black")
- ) +
- scale_shape_manual(name = "Toxicity", values = c(Yes = 17, No = 16)) +
- scale_x_continuous(breaks = df$patient, minor_breaks = NULL) +
- scale_y_continuous(
- breaks = sort(unique(c(0, df$dose))),
- minor_breaks = NULL,
- limits = c(0, max(df$dose) * 1.1)
- ) +
- xlab("Patient") +
- ylab("Dose Level")
-
- p <- p + h_plot_data_cohort_lines(df$cohort, placebo = x@placebo)
-
- if (!blind) {
- p <- p +
- geom_text(
- aes(label = ID, size = 2),
- data = df,
- hjust = 0,
- vjust = 0.5,
- angle = 90,
- colour = "black",
- show.legend = FALSE
- )
+ signature = signature(x = "DataOrdinal", y = "missing"),
+ definition = function(x,
+ y,
+ blind = FALSE,
+ legend = TRUE,
+ tox_labels = NULL,
+ tox_shapes = NULL,
+ ...) {
+ if (is.null(tox_shapes)) {
+ assert_true(length(x@yCategories) <= 9)
+ tox_shapes <- c(17L, 16L, 15L, 18L, 0L:2L, 5L, 6L)[seq_along(x@yCategories)]
+ names(tox_shapes) <- names(x@yCategories)
}
-
- if (!legend) {
- p <- p + theme(legend.position = "none")
+ if (is.null(tox_labels)) {
+ assert_true(length(x@yCategories) <= 5)
+ tox_labels <- switch(length(x@yCategories),
+ c("black"),
+ c("black", "red"),
+ c("black", "orange", "red"),
+ c("black", "green", "orange", "red"),
+ c("black", "green", "yellow", "orange", "red")
+ )
+ names(tox_labels) <- names(x@yCategories)
}
-
- p
+ h_plot_data_dataordinal(
+ x,
+ blind,
+ legend,
+ tox_labels = tox_labels,
+ tox_shapes = tox_shapes,
+ ...
+ )
}
)
@@ -249,7 +267,12 @@ setMethod(
#' @param new_cohort (`flag`)\cr if `TRUE` (default) the new data are assigned
#' to a new cohort.
#' @param check (`flag`)\cr whether the validation of the updated object should
-#' be conducted. Current implementation of this `update` method allows for
+#' be conducted. See details below.
+#' @param ... not used.
+#'
+#' @return The new, updated [`Data`] object.
+#'
+#' @details The current implementation of this `update` method allows for
#' updating the `Data` class object by adding a single dose level `x` only.
#' However, there might be some use cases where the new cohort to be added
#' contains a placebo and active dose. Hence, such update would need to be
@@ -259,9 +282,6 @@ setMethod(
#' the `update` method would normally throw the error when attempting to add
#' a placebo in the first call. To allow for such updates, the `check`
#' parameter should be then set to `FALSE` for that first call.
-#' @param ... not used.
-#'
-#' @return The new, updated [`Data`] object.
#'
#' @aliases update-Data
#' @export
@@ -319,6 +339,97 @@ setMethod(
}
)
+## DataOrdinal ----
+
+#' Updating `DataOrdinal` Objects
+#'
+#' @description `r lifecycle::badge("experimental")`
+#'
+#' A method that updates existing [`DataOrdinal`] object with new data.
+#'
+#' @param object (`DataOrdinal`)\cr object you want to update.
+#' @param x (`number`)\cr the dose level (one level only!).
+#' @param y (`integer`)\cr the vector of toxicity grades (0, 1, 2, ...) for all
+#' patients in this cohort. You can also supply `numeric` vectors, but these
+#' will then be converted to `integer` internally.
+#' @param ID (`integer`)\cr the patient IDs.
+#' You can also supply `numeric` vectors, but these will then be converted to
+#' `integer` internally.
+#' @param new_cohort (`flag`)\cr if `TRUE` (default) the new data are assigned
+#' to a new cohort.
+#' @param check (`flag`)\cr whether the validation of the updated object should
+#' be conducted. See Details below.
+#' @param ... not used.
+#'
+#' @return The new, updated [`DataOrdinal`] object.
+#'
+#' @details The current implementation of this `update` method allows for
+#' updating the `DataOrdinal` class object by adding a single dose level `x` only.
+#' However, there might be some use cases where the new cohort to be added
+#' contains a placebo and active dose. Hence, such update would need to be
+#' performed iteratively by calling the `update` method twice. For example,
+#' in the first call a user can add a placebo, and then in the second call,
+#' an active dose. Since having a cohort with placebo only is not allowed,
+#' the `update` method would normally throw the error when attempting to add
+#' a placebo in the first call. To allow for such updates, the `check`
+#' parameter should be then set to `FALSE` for that first call.
+#'
+#' @aliases update-DataOrdinal
+#' @export
+#' @example examples/DataOrdinal-method-update.R
+#'
+setMethod(
+ f = "update",
+ signature = signature(object = "DataOrdinal"),
+ definition = function(object,
+ x,
+ y,
+ ID = length(object@ID) + seq_along(y),
+ new_cohort = TRUE,
+ check = TRUE,
+ ...) {
+ assert_numeric(x, min.len = 0, max.len = 1)
+ assert_numeric(y, lower = 0, upper = length(object@yCategories) - 1)
+ assert_numeric(ID, len = length(y))
+ assert_disjunct(object@ID, ID)
+ assert_flag(new_cohort)
+ assert_flag(check)
+
+ # How many additional patients, ie. the length of the update.
+ n <- length(y)
+
+ # Which grid level is the dose?
+ gridLevel <- matchTolerance(x, object@doseGrid)
+ object@xLevel <- c(object@xLevel, rep(gridLevel, n))
+
+ # Add dose.
+ object@x <- c(object@x, rep(as.numeric(x), n))
+
+ # Add DLT data.
+ object@y <- c(object@y, safeInteger(y))
+
+ # Add ID.
+ object@ID <- c(object@ID, safeInteger(ID))
+
+ # Add cohort number.
+ new_cohort_id <- if (object@nObs == 0) {
+ 1L
+ } else {
+ tail(object@cohort, 1L) + ifelse(new_cohort, 1L, 0L)
+ }
+ object@cohort <- c(object@cohort, rep(new_cohort_id, n))
+
+ # Increment sample size.
+ object@nObs <- object@nObs + n
+
+ if (check) {
+ validObject(object)
+ }
+
+ object
+ }
+)
+
## DataParts ----
#' Updating `DataParts` Objects
@@ -647,18 +758,26 @@ setMethod(
f = "dose_grid_range",
signature = signature(object = "Data"),
definition = function(object, ignore_placebo = TRUE) {
- assert_flag(ignore_placebo)
+ h_obtain_dose_grid_range(object, ignore_placebo)
+ }
+)
- dose_grid <- if (ignore_placebo && object@placebo && object@nGrid >= 1) {
- object@doseGrid[-1]
- } else {
- object@doseGrid
- }
- if (length(dose_grid) == 0L) {
- c(-Inf, Inf)
- } else {
- range(dose_grid)
- }
+## DataOrdinal ----
+
+#' @include Data-methods.R
+#' @rdname dose_grid_range
+#' @description `r lifecycle::badge("experimental")`
+#'
+#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
+#'
+#' @aliases dose_grid_range-Data
+#' @example examples/DataOrdinal-method-dose_grid_range.R
+#'
+setMethod(
+ f = "dose_grid_range",
+ signature = signature(object = "DataOrdinal"),
+ definition = function(object, ignore_placebo = TRUE) {
+ h_obtain_dose_grid_range(object, ignore_placebo)
}
)
diff --git a/R/Data-validity.R b/R/Data-validity.R
index e424a5aee..08a0ffee8 100644
--- a/R/Data-validity.R
+++ b/R/Data-validity.R
@@ -48,18 +48,17 @@ h_doses_unique_per_cohort <- function(dose, cohort) {
all(num_doses_per_cohort == 1L)
}
-#' @describeIn v_data_objects validates that the [`Data`] object contains
-#' valid elements with respect to their types, dependency and length.
-v_data <- function(object) {
+#' Helper Function performing validation Common to Data and DataOrdinal
+#'
+#' @rdname h_validate_common_data_slots
+#' @param object (`Data` or `DataOrdinal`)\cr the object to be validated
+#' @returns a `Validate` object containing the result of the validation
+h_validate_common_data_slots <- function(object) {
v <- Validate()
v$check(
test_double(object@x, len = object@nObs, any.missing = FALSE),
"Doses vector x must be of type double and length nObs"
)
- v$check(
- test_integer(object@y, lower = 0, upper = 1, len = object@nObs, any.missing = FALSE),
- "DLT vector y must be nObs long and contain 0 or 1 integers only"
- )
v$check(
test_double(object@doseGrid, len = object@nGrid, any.missing = FALSE, unique = TRUE, sorted = TRUE),
"doseGrid must be of type double and length nGrid and contain unique, sorted values"
@@ -97,9 +96,21 @@ v_data <- function(object) {
} else {
v$check(
h_doses_unique_per_cohort(dose = object@x, cohort = object@cohort),
- "There must be only one dose level, per cohort"
+ "There must be only one dose level per cohort"
)
}
+ v
+}
+
+#' @describeIn v_data_objects validates that the [`Data`] object contains
+#' valid elements with respect to their types, dependency and length.
+v_data <- function(object) {
+ v <- h_validate_common_data_slots(object)
+ v$check(
+ test_integer(object@y, lower = 0, upper = 1, len = object@nObs, any.missing = FALSE),
+ "DLT vector y must be nObs long and contain 0 or 1 integers only"
+ )
+
v$result()
}
@@ -181,6 +192,21 @@ v_data_da <- function(object) {
v$result()
}
+#' @describeIn v_data_objects validates that the [`DataOrdinal`] object
+#' contains valid elements with respect to their types, dependency and length.
+v_data_ordinal <- function(object) {
+ v <- h_validate_common_data_slots(object)
+ v$check(
+ test_integer(object@y, lower = 0, upper = length(object@yCategories) - 1, len = object@nObs, any.missing = FALSE),
+ "DLT vector y must be nObs long and contain integers between 0 and k-1 only, where k is the length of the vector in the yCategories slot" # nolint
+ )
+ v$check(
+ length(unique(names(object@yCategories))) == length(names(object@yCategories)),
+ "yCategory labels must be unique"
+ )
+ v$result()
+}
+
#' @describeIn v_data_objects validates that the [`DataGrouped`] object
#' contains valid group information.
v_data_grouped <- function(object) {
diff --git a/R/Design-class.R b/R/Design-class.R
index a0687ccbc..05db7632b 100644
--- a/R/Design-class.R
+++ b/R/Design-class.R
@@ -529,3 +529,90 @@ DADesign <- function(model, data,
safetyWindow = safetyWindow
)
}
+
+# DesignGrouped ----
+
+## class ----
+
+#' `DesignGrouped`
+#'
+#' @description `r lifecycle::badge("experimental")`
+#'
+#' [`DesignGrouped`] combines two [`Design`] objects: one for the mono and one
+#' for the combo arm of a joint dose escalation design.
+#'
+#' @slot model (`LogisticLogNormalGrouped`)\cr the model to be used, currently only one
+#' class is allowed.
+#' @slot mono (`Design`)\cr defines the dose escalation rules for the mono arm, see
+#' details.
+#' @slot combo (`Design`)\cr defines the dose escalation rules for the combo arm, see
+#' details.
+#' @slot first_cohort_mono_only (`flag`)\cr whether first test one mono agent cohort, and then
+#' once its DLT data has been collected, we proceed from the second cohort onwards with
+#' concurrent mono and combo cohorts.
+#' @slot same_dose (`flag`)\cr whether the lower dose of the separately determined mono and combo
+#' doses should be used as the next dose for both mono and combo.
+#'
+#' @details Note that the model slots inside the `mono` and `combo` parameters
+#' are ignored (because we don't fit separate regression models for the mono and
+#' combo arms). Instead, the `model` parameter is used to fit a joint regression
+#' model for the mono and combo arms together.
+#'
+#' @aliases DesignGrouped
+#' @export
+#'
+.DesignGrouped <- setClass(
+ Class = "DesignGrouped",
+ slots = c(
+ model = "LogisticLogNormalGrouped",
+ mono = "Design",
+ combo = "Design",
+ first_cohort_mono_only = "logical",
+ same_dose = "logical"
+ ),
+ prototype = prototype(
+ model = .DefaultLogisticLogNormalGrouped(),
+ mono = .Design(),
+ combo = .Design(),
+ first_cohort_mono_only = TRUE,
+ same_dose = TRUE
+ ),
+ validity = v_design_grouped,
+ contains = "CrmPackClass"
+)
+
+## constructor ----
+
+#' @rdname DesignGrouped-class
+#'
+#' @param model (`LogisticLogNormalGrouped`)\cr see slot definition.
+#' @param mono (`Design`)\cr see slot definition.
+#' @param combo (`Design`)\cr see slot definition.
+#' @param first_cohort_mono_only (`flag`)\cr see slot definition.
+#' @param same_dose (`flag`)\cr see slot definition.
+#' @param ... not used.
+#'
+#' @export
+#' @example examples/Design-class-DesignGrouped.R
+#'
+DesignGrouped <- function(model,
+ mono,
+ combo = mono,
+ first_cohort_mono_only = TRUE,
+ same_dose = TRUE,
+ ...) {
+ .DesignGrouped(
+ model = model,
+ mono = mono,
+ combo = combo,
+ first_cohort_mono_only = first_cohort_mono_only,
+ same_dose = same_dose
+ )
+}
+
+## default constructor ----
+
+#' @rdname DesignGrouped-class
+#' @note Typically, end-users will not use the `.DefaultDesignGrouped()` function.
+#' @export
+.DefaultDesignGrouped <- .DesignGrouped
diff --git a/R/Design-methods.R b/R/Design-methods.R
index 4cbdcbe70..e9a48f422 100644
--- a/R/Design-methods.R
+++ b/R/Design-methods.R
@@ -1,165 +1,13 @@
-# nolint start
-#####################################################################################
-## Author: Daniel Sabanes Bove [sabanesd *a*t* roche *.* com]
-## Wai Yin Yeung [w*.* yeung1 *a*t* lancaster *.* ac *.* uk]
-## Project: Object-oriented implementation of CRM designs
-##
-## Time-stamp: <[Design-methods.R] by DSB Son 03/05/2015 20:35>
-##
-## Description:
-## Simulate outcomes from a CRM trial, assuming a true dose-toxicity
-## relationship.
-##
-## History:
-## 12/02/2014 file creation
-## 07/04/2014 start with parallelization on cores
-## 02/01/2015 rename: simulate.R --> Design-methods.R
-## 10/07/2015 added simulate methods
-#####################################################################################
-
-##' @include Data-methods.R
-##' @include Design-class.R
-##' @include McmcOptions-class.R
-##' @include Rules-methods.R
-##' @include Simulations-class.R
-##' @include helpers.R
-##' @include mcmc.R
-{}
-
-##' Helper function to set and save the RNG seed
-##'
-##' This is basically copied from simulate.lm
-##'
-##' @param seed an object specifying if and how the random number generator
-##' should be initialized (\dQuote{seeded}). Either \code{NULL} (default) or an
-##' integer that will be used in a call to \code{\link{set.seed}} before
-##' simulating the response vectors. If set, the value is saved as the
-##' \code{seed} slot of the returned object. The default, \code{NULL} will
-##' not change the random generator state.
-##' @return The RNGstate will be returned, in order to call this function
-##' with this input to reproduce the obtained simulation results
-##'
-##' @export
-##' @keywords programming
-##' @author Daniel Sabanes Bove \email{sabanesd@@roche.com}
-setSeed <- function(seed = NULL) {
- if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
- runif(1)
- }
-
- if (is.null(seed)) {
- RNGstate <- get(".Random.seed", envir = .GlobalEnv)
- } else {
- R.seed <- get(".Random.seed", envir = .GlobalEnv)
- ## make sure R.seed exists in parent frame:
- assign("R.seed", R.seed, envir = parent.frame())
- set.seed(seed)
- RNGstate <- structure(seed, kind = as.list(RNGkind()))
- do.call("on.exit",
- list(quote(assign(".Random.seed", R.seed, envir = .GlobalEnv))),
- envir = parent.frame()
- )
- ## here we need the R.seed in the parent.frame!
- }
-
- return(RNGstate)
-}
-
-
-##' Helper function to obtain simulation results list
-##'
-##' The function \code{fun} can use variables that are visible to itself.
-##' The names of these variables have to given in the vector \code{vars}.
-##'
-##' @param fun the simulation function for a single iteration, which takes as
-##' single parameter the iteration index
-##' @param nsim number of simulations to be conducted
-##' @param vars names of the variables
-##' @param parallel shall the iterations be parallelized across the cores?
-##' if NULL, then no parallelization will be done. If scalar positive number,
-##' then so many cores will be used.
-##' @return the list with all simulation results (one iteration corresponds
-##' to one list element)
-##'
-##' @importFrom parallel detectCores makeCluster clusterApply stopCluster
-##' @importFrom parallelly availableCores
-##' @keywords internal programming
-##' @author Daniel Sabanes Bove \email{sabanesd@@roche.com}
-getResultList <- function(fun,
- nsim,
- vars,
- parallel = NULL) {
- ret <-
- if (is.null(parallel)) {
- lapply(
- X = seq_len(nsim),
- FUN = fun
- )
- } else {
- ## check that parallel parameter makes sense
- stopifnot(is.scalar(parallel), parallel > 0)
-
- ## now process all simulations
- cores <- min(
- safeInteger(parallel),
- parallelly::availableCores()
- )
-
- ## start the cluster
- cl <- parallel::makeCluster(cores)
-
- ## load the required R package
- parallel::clusterEvalQ(cl, {
- library(crmPack)
- NULL
- })
-
- ## export local variables
- parallel::clusterExport(
- cl = cl,
- varlist = vars,
- envir = parent.frame()
- )
- ## parent.frame() gives back the caller environment
- ## (different from parent.env() which returns
- ## the environment where this function has been
- ## defined!)
-
- ## export all global variables
- parallel::clusterExport(
- cl = cl,
- varlist = ls(.GlobalEnv)
- )
-
- # load user extensions from global options
- crmpack_extensions <- getOption("crmpack_extensions")
- if (is.null(crmpack_extensions) != TRUE) {
- tryCatch(
- {
- parallel::clusterCall(cl, crmpack_extensions)
- },
- error = function(e) {
- stop("Failed to export crmpack_extensions: ", e$message)
- }
- )
- }
-
- ## now do the computations
- res <- parallel::parLapply(
- cl = cl,
- X = seq_len(nsim),
- fun = fun
- )
-
- ## stop the cluster
- parallel::stopCluster(cl)
-
- res
- }
-
- return(ret)
-}
+#' @include Data-methods.R
+#' @include Design-class.R
+#' @include McmcOptions-class.R
+#' @include Rules-methods.R
+#' @include Simulations-class.R
+#' @include helpers.R
+#' @include mcmc.R
+NULL
+# nolint start
## ============================================================
@@ -168,7 +16,7 @@ getResultList <- function(fun,
##' @param object the \code{\linkS4class{Design}} object we want to simulate
##' data from
##' @param nsim the number of simulations (default: 1)
-##' @param seed see \code{\link{setSeed}}
+##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity. Additional arguments can be supplied
##' in \code{args}.
@@ -231,7 +79,7 @@ setMethod("simulate",
nArgs <- max(nrow(args), 1L)
## seed handling
- RNGstate <- setSeed(seed)
+ RNGstate <- set_seed(seed)
## from this,
## generate the individual seeds for the simulation runs
@@ -452,7 +300,7 @@ setMethod("simulate",
return(thisResult)
}
- resultList <- getResultList(
+ resultList <- get_result_list(
fun = runSim,
nsim = nsim,
vars =
@@ -465,7 +313,8 @@ setMethod("simulate",
"object",
"mcmcOptions"
),
- parallel = if (parallel) nCores else NULL
+ parallel = parallel,
+ n_cores = nCores
)
## put everything in the Simulations format:
@@ -512,7 +361,7 @@ setMethod("simulate",
##' @param object the \code{\linkS4class{RuleDesign}} object we want to simulate
##' data from
##' @param nsim the number of simulations (default: 1)
-##' @param seed see \code{\link{setSeed}}
+##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity. Additional arguments can be supplied
##' in \code{args}.
@@ -559,7 +408,7 @@ setMethod("simulate",
nArgs <- max(nrow(args), 1L)
## seed handling
- RNGstate <- setSeed(seed)
+ RNGstate <- set_seed(seed)
## from this,
## generate the individual seeds for the simulation runs
@@ -644,7 +493,7 @@ setMethod("simulate",
return(thisResult)
}
- resultList <- getResultList(
+ resultList <- get_result_list(
fun = runSim,
nsim = nsim,
vars =
@@ -655,7 +504,8 @@ setMethod("simulate",
"truth",
"object"
),
- parallel = if (parallel) nCores else NULL
+ parallel = parallel,
+ n_cores = nCores
)
## put everything in the GeneralSimulations format:
@@ -683,7 +533,7 @@ setMethod("simulate",
##' @param object the \code{\linkS4class{DualDesign}} object we want to simulate
##' data from
##' @param nsim the number of simulations (default: 1)
-##' @param seed see \code{\link{setSeed}}
+##' @param seed see \code{\link{set_seed}}
##' @param trueTox a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity. Additional arguments can be supplied
##' in \code{args}.
@@ -762,7 +612,7 @@ setMethod("simulate",
)
## seed handling
- RNGstate <- setSeed(seed)
+ RNGstate <- set_seed(seed)
## from this,
## generate the individual seeds for the simulation runs
@@ -1068,7 +918,7 @@ setMethod("simulate",
return(thisResult)
}
- resultList <- getResultList(
+ resultList <- get_result_list(
fun = runSim,
nsim = nsim,
vars =
@@ -1083,7 +933,8 @@ setMethod("simulate",
"object",
"mcmcOptions"
),
- parallel = if (parallel) nCores else NULL
+ parallel = parallel,
+ n_cores = nCores
)
## put everything in the Simulations format:
@@ -1904,7 +1755,7 @@ setMethod("examine",
##'
##' @param object the \code{\linkS4class{TDsamplesDesign}} object we want to simulate the data from
##' @param nsim the number of simulations (default :1)
-##' @param seed see \code{\link{setSeed}}
+##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param args data frame with arguments for the \code{truth} function. The
@@ -1962,7 +1813,7 @@ setMethod("simulate",
## seed handling
- RNGstate <- setSeed(seed)
+ RNGstate <- set_seed(seed)
## from this,
## generate the individual seeds for the simulation runs
@@ -2188,7 +2039,7 @@ setMethod("simulate",
return(thisResult)
}
- resultList <- getResultList(
+ resultList <- get_result_list(
fun = runSim,
nsim = nsim,
vars =
@@ -2201,7 +2052,8 @@ setMethod("simulate",
"object",
"mcmcOptions"
),
- parallel = if (parallel) nCores else NULL
+ parallel = parallel,
+ n_cores = nCores
)
## put everything in the Simulations format:
@@ -2273,7 +2125,7 @@ setMethod("simulate",
##'
##' @param object the \code{\linkS4class{TDDesign}} object we want to simulate the data from
##' @param nsim the number of simulations (default :1)
-##' @param seed see \code{\link{setSeed}}
+##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param args data frame with arguments for the \code{truth} function. The
@@ -2326,7 +2178,7 @@ setMethod("simulate",
nArgs <- max(nrow(args), 1L)
## seed handling
- RNGstate <- setSeed(seed)
+ RNGstate <- set_seed(seed)
## from this,
## generate the individual seeds for the simulation runs
@@ -2535,7 +2387,7 @@ setMethod("simulate",
}
- resultList <- getResultList(
+ resultList <- get_result_list(
fun = runSim,
nsim = nsim,
vars =
@@ -2547,7 +2399,8 @@ setMethod("simulate",
"truth",
"object"
),
- parallel = if (parallel) nCores else NULL
+ parallel = parallel,
+ n_cores = nCores
)
## put everything in the Simulations format:
@@ -2622,7 +2475,7 @@ setMethod("simulate",
##'
##' @param object the \code{\linkS4class{DualResponsesDesign}} object we want to simulate the data from
##' @param nsim the number of simulations (default :1)
-##' @param seed see \code{\link{setSeed}}
+##' @param seed see \code{\link{set_seed}}
##' @param trueDLE a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param trueEff a function which takes as input a dose (vector) and returns the expected efficacy
@@ -2685,7 +2538,7 @@ setMethod("simulate",
## seed handling
- RNGstate <- setSeed(seed)
+ RNGstate <- set_seed(seed)
## from this,
## generate the individual seeds for the simulation runs
@@ -3025,7 +2878,7 @@ setMethod("simulate",
}
- resultList <- getResultList(
+ resultList <- get_result_list(
fun = runSim,
nsim = nsim,
vars =
@@ -3039,7 +2892,8 @@ setMethod("simulate",
"trueNu",
"object"
),
- parallel = if (parallel) nCores else NULL
+ parallel = parallel,
+ n_cores = nCores
)
@@ -3152,7 +3006,7 @@ setMethod("simulate",
##' @param object the \code{\linkS4class{DualResponsesSamplesDesign}} object we want to
##' simulate the data from
##' @param nsim the number of simulations (default :1)
-##' @param seed see \code{\link{setSeed}}
+##' @param seed see \code{\link{set_seed}}
##' @param trueDLE a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param trueEff a function which takes as input a dose (vector) and returns the expected
@@ -3233,7 +3087,7 @@ setMethod("simulate",
trueDLEArgnames <- names(formals(trueDLE))[-1]
## seed handling
- RNGstate <- setSeed(seed)
+ RNGstate <- set_seed(seed)
## from this,
## generate the individual seeds for the simulation runs
@@ -3571,7 +3425,7 @@ setMethod("simulate",
return(thisResult)
}
- resultList <- getResultList(
+ resultList <- get_result_list(
fun = runSim,
nsim = nsim,
vars =
@@ -3587,7 +3441,8 @@ setMethod("simulate",
"object",
"mcmcOptions"
),
- parallel = if (parallel) nCores else NULL
+ parallel = parallel,
+ n_cores = nCores
)
## put everything in the Simulations format:
@@ -3698,7 +3553,7 @@ setMethod("simulate",
## seed handling
- RNGstate <- setSeed(seed)
+ RNGstate <- set_seed(seed)
## from this,
## generate the individual seeds for the simulation runs
@@ -4041,7 +3896,7 @@ setMethod("simulate",
}
- resultList <- getResultList(
+ resultList <- get_result_list(
fun = runSim,
nsim = nsim,
vars =
@@ -4055,7 +3910,8 @@ setMethod("simulate",
"trueNu",
"object"
),
- parallel = if (parallel) nCores else NULL
+ parallel = parallel,
+ n_cores = nCores
)
@@ -4154,7 +4010,7 @@ setMethod("simulate",
##' @param object the \code{\linkS4class{DADesign}} object we want to simulate
##' data from
##' @param nsim the number of simulations (default: 1)
-##' @param seed see \code{\link{setSeed}}
+##' @param seed see \code{\link{set_seed}}
##' @param truthTox a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity and the time DLT occurs. Additional
##' arguments can be supplied in \code{args}.
@@ -4226,7 +4082,7 @@ setMethod("simulate",
nArgs <- max(nrow(args), 1L)
## seed handling
- RNGstate <- setSeed(seed)
+ RNGstate <- set_seed(seed)
## from this,
## generate the individual seeds for the simulation runs
@@ -4714,7 +4570,7 @@ setMethod("simulate",
return(thisResult)
}
- resultList <- getResultList(
+ resultList <- get_result_list(
fun = runSim, ## remove
nsim = nsim,
vars =
@@ -4730,7 +4586,8 @@ setMethod("simulate",
"nextOpen",
"ready_to_open"
),
- parallel = if (parallel) nCores else NULL
+ parallel = parallel,
+ n_cores = nCores
)
## put everything in the Simulations format:
@@ -4774,3 +4631,170 @@ setMethod("simulate",
## --------------------------------------------------------------------------
# nolint end
+
+# simulate ----
+
+## DesignGrouped ----
+
+#' Simulate Method for the [`DesignGrouped`] Class
+#'
+#' @description `r lifecycle::badge("experimental")`
+#'
+#' A simulate method for [`DesignGrouped`] designs.
+#'
+#' @param object (`DesignGrouped`)\cr the design we want to simulate trials from.
+#' @param nsim (`number`)\cr how many trials should be simulated.
+#' @param seed (`RNGstate`)\cr generated with [set_seed()].
+#' @param truth (`function`)\cr a function which takes as input a dose (vector) and
+#' returns the true probability (vector) for toxicity for the mono arm.
+#' Additional arguments can be supplied in `args`.
+#' @param combo_truth (`function`)\cr same as `truth` but for the combo arm.
+#' @param args (`data.frame`)\cr optional `data.frame` with arguments that work
+#' for both the `truth` and `combo_truth` functions. The column names correspond to
+#' the argument names, the rows to the values of the arguments. The rows are
+#' appropriately recycled in the `nsim` simulations.
+#' @param firstSeparate (`flag`)\cr whether to enroll the first patient separately
+#' from the rest of the cohort and close the cohort in case a DLT occurs in this
+#' first patient.
+#' @param mcmcOptions (`McmcOptions`)\cr MCMC options for each evaluation in the trial.
+#' @param parallel (`flag`)\cr whether the simulation runs are parallelized across the
+#' cores of the computer.
+#' @param nCores (`number`)\cr how many cores should be used for parallel computing.
+#' @param ... not used.
+#'
+#' @return A list of `mono` and `combo` simulation results as [`Simulations`] objects.
+#'
+#' @aliases simulate-DesignGrouped
+#' @export
+#' @example examples/Design-method-simulate-DesignGrouped.R
+#'
+setMethod(
+ "simulate",
+ signature =
+ signature(
+ object = "DesignGrouped",
+ nsim = "ANY",
+ seed = "ANY"
+ ),
+ def =
+ function(object,
+ nsim = 1L,
+ seed = NULL,
+ truth,
+ combo_truth,
+ args = data.frame(),
+ firstSeparate = FALSE,
+ mcmcOptions = McmcOptions(),
+ parallel = FALSE,
+ nCores = min(parallelly::availableCores(), 5),
+ ...) {
+ nsim <- safeInteger(nsim)
+ assert_function(truth)
+ assert_function(combo_truth)
+ assert_data_frame(args)
+ assert_count(nsim, positive = TRUE)
+ assert_flag(firstSeparate)
+ assert_flag(parallel)
+ assert_count(nCores, positive = TRUE)
+
+ n_args <- max(nrow(args), 1L)
+ rng_state <- set_seed(seed)
+ sim_seeds <- sample.int(n = 2147483647, size = nsim)
+
+ run_sim <- function(iter_sim) {
+ set.seed(sim_seeds[iter_sim])
+ current <- list(mono = list(), combo = list())
+ # Define true toxicity functions.
+ current$args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]
+ current$mono$truth <- function(dose) do.call(truth, c(dose, current$args))
+ current$combo$truth <- function(dose) do.call(combo_truth, c(dose, current$args))
+ # Start the simulated data with the provided one.
+ current$mono$data <- object@mono@data
+ current$combo$data <- object@combo@data
+ # We are in the first cohort and continue for mono and combo.
+ current$first <- TRUE
+ current$mono$stop <- current$combo$stop <- FALSE
+ # What are the next doses to be used? Initialize with starting doses.
+ if (object@same_dose) {
+ current$mono$dose <- current$combo$dose <- min(object@mono@startingDose, object@combo@startingDose)
+ } else {
+ current$mono$dose <- object@mono@startingDose
+ current$combo$dose <- object@combo@startingDose
+ }
+ # Inside this loop we simulate the whole trial, until stopping.
+ while (!(current$mono$stop && current$combo$stop)) {
+ if (!current$mono$stop) {
+ current$mono$data <- current$mono$data |>
+ h_add_dlts(current$mono$dose, current$mono$truth, object@mono@cohort_size, firstSeparate)
+ }
+ if (!current$combo$stop && (!current$first || !object@first_cohort_mono_only)) {
+ current$combo$data <- current$combo$data |>
+ h_add_dlts(current$combo$dose, current$combo$truth, object@combo@cohort_size, firstSeparate)
+ }
+ if (current$first) current$first <- FALSE
+ current$grouped <- h_group_data(current$mono$data, current$combo$data)
+ current$samples <- mcmc(current$grouped, object@model, mcmcOptions)
+ if (!current$mono$stop) {
+ current$mono$limit <- maxDose(object@mono@increments, data = current$mono$data)
+ current$mono$dose <- object@mono@nextBest |>
+ nextBest(current$mono$limit, current$samples, object@model, current$grouped, group = "mono")
+ current$mono$dose <- current$mono$dose$value
+ current$mono$stop <- object@mono@stopping |>
+ stopTrial(current$mono$dose, current$samples, object@model, current$mono$data, group = "mono")
+ current$mono$results <- h_unpack_stopit(current$mono$stop)
+ }
+ if (!current$combo$stop) {
+ current$combo$limit <- if (is.na(current$mono$dose)) {
+ 0
+ } else {
+ maxDose(object@combo@increments, current$combo$data) |>
+ min(current$mono$dose, na.rm = TRUE)
+ }
+ current$combo$dose <- object@combo@nextBest |>
+ nextBest(current$combo$limit, current$samples, object@model, current$grouped, group = "combo")
+ current$combo$dose <- current$combo$dose$value
+ current$combo$stop <- object@combo@stopping |>
+ stopTrial(current$combo$dose, current$samples, object@model, current$combo$data, group = "combo")
+ current$combo$results <- h_unpack_stopit(current$combo$stop)
+ }
+ if (object@same_dose && !current$mono$stop && !current$combo$stop) {
+ current$mono$dose <- current$combo$dose <- min(current$mono$dose, current$combo$dose)
+ }
+ }
+ current$mono$fit <- fit(current$samples, object@model, current$grouped, group = "mono")
+ current$combo$fit <- fit(current$samples, object@model, current$grouped, group = "combo")
+ lapply(
+ X = current[c("mono", "combo")], FUN = with,
+ list(
+ data = data, dose = dose, fit = subset(fit, select = -dose),
+ stop = attr(stop, "message"), results = results
+ )
+ )
+ }
+ vars_needed <- c("simSeeds", "args", "nArgs", "truth", "combo_truth", "firstSeparate", "object", "mcmcOptions")
+ result_list <- get_result_list(run_sim, nsim, vars_needed, parallel, nCores)
+ # Now we have a list with each element containing mono and combo. Reorder this a bit:
+ result_list <- list(
+ mono = lapply(result_list, "[[", "mono"),
+ combo = lapply(result_list, "[[", "combo")
+ )
+ # Put everything in a list with both mono and combo Simulations:
+ lapply(result_list, function(this_list) {
+ data_list <- lapply(this_list, "[[", "data")
+ recommended_doses <- as.numeric(sapply(this_list, "[[", "dose"))
+ fit_list <- lapply(this_list, "[[", "fit")
+ stop_reasons <- lapply(this_list, "[[", "stop")
+ report_results <- lapply(this_list, "[[", "results")
+ stop_report <- as.matrix(do.call(rbind, report_results))
+
+ Simulations(
+ data = data_list,
+ doses = recommended_doses,
+ fit = fit_list,
+ stop_reasons = stop_reasons,
+ stop_report = stop_report,
+ seed = rng_state
+ )
+ })
+ }
+)
diff --git a/R/Design-validity.R b/R/Design-validity.R
index d20b0f4ca..e5e53be4c 100644
--- a/R/Design-validity.R
+++ b/R/Design-validity.R
@@ -27,3 +27,19 @@ v_rule_design <- function(object) {
)
v$result()
}
+
+
+#' @describeIn v_design validates that the [`DesignGrouped`] object
+#' contains valid flags.
+v_design_grouped <- function(object) {
+ v <- Validate()
+ v$check(
+ test_flag(object@first_cohort_mono_only),
+ "first_cohort_mono_only must be a flag"
+ )
+ v$check(
+ test_flag(object@same_dose),
+ "same_dose must be a flag"
+ )
+ v$result()
+}
diff --git a/R/Rules-methods.R b/R/Rules-methods.R
index 8d5d32127..dd3af7367 100644
--- a/R/Rules-methods.R
+++ b/R/Rules-methods.R
@@ -67,7 +67,7 @@ setMethod(
),
definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
# Generate the MTD samples and derive the next best dose.
- dose_target_samples <- dose(x = nextBest@target, model, samples)
+ dose_target_samples <- dose(x = nextBest@target, model, samples, ...)
dose_target <- nextBest@derive(dose_target_samples)
# Round to the next possible grid point.
@@ -292,7 +292,7 @@ setMethod("nextBest",
),
definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
# Matrix with samples from the dose-tox curve at the dose grid points.
- prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples)
+ prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)
# Compute probabilities to be in target and overdose tox interval.
prob_underdosing <- colMeans(prob_samples < nextBest@target[1])
prob_target <- colMeans(h_in_range(prob_samples, nextBest@target))
@@ -553,7 +553,7 @@ setMethod(
),
definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
# Matrix with samples from the dose-tox curve at the dose grid points.
- prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples)
+ prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)
dlt_prob <- colMeans(prob_samples)
# Determine the dose with the closest distance.
@@ -651,7 +651,7 @@ setMethod(
),
definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
# Matrix with samples from the dose-tox curve at the dose grid points.
- prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples)
+ prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)
criterion <- colMeans(h_info_theory_dist(prob_samples, nextBest@target, nextBest@asymmetry))
@@ -697,8 +697,8 @@ setMethod(
# Target dose estimates, i.e. the dose with probability of the occurrence of
# a DLT that equals to the prob_target_drt or prob_target_eot.
- dose_target_drt <- dose(x = prob_target_drt, model)
- dose_target_eot <- dose(x = prob_target_eot, model)
+ dose_target_drt <- dose(x = prob_target_drt, model, ...)
+ dose_target_eot <- dose(x = prob_target_eot, model, ...)
# Find the next best doses in the doseGrid. The next best dose is the dose
# at level closest and below the target dose estimate.
@@ -732,7 +732,7 @@ setMethod(
prob_target_eot = prob_target_eot,
dose_target_eot = dose_target_eot,
data = data,
- prob_dlt = prob(dose = data@doseGrid, model = model),
+ prob_dlt = prob(dose = data@doseGrid, model = model, ...),
doselimit = doselimit,
next_dose = next_dose_drt
)
@@ -777,12 +777,12 @@ setMethod(
model = "LogisticIndepBeta",
data = "Data"
),
- definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
+ definition = function(nextBest, doselimit = Inf, samples, model, data, in_sim, ...) {
# Generate target dose samples, i.e. the doses with probability of the
# occurrence of a DLT that equals to the nextBest@prob_target_drt
# (or nextBest@prob_target_eot, respectively).
- dose_target_drt_samples <- dose(x = nextBest@prob_target_drt, model, samples)
- dose_target_eot_samples <- dose(x = nextBest@prob_target_eot, model, samples)
+ dose_target_drt_samples <- dose(x = nextBest@prob_target_drt, model, samples, ...)
+ dose_target_eot_samples <- dose(x = nextBest@prob_target_eot, model, samples, ...)
# Derive the prior/posterior estimates based on two above samples.
dose_target_drt <- nextBest@derive(dose_target_drt_samples)
@@ -865,15 +865,15 @@ setMethod(
# Target dose estimates, i.e. the dose with probability of the occurrence of
# a DLT that equals to the prob_target_drt or prob_target_eot.
- dose_target_drt <- dose(x = prob_target_drt, model)
- dose_target_eot <- dose(x = prob_target_eot, model)
+ dose_target_drt <- dose(x = prob_target_drt, model, ...)
+ dose_target_eot <- dose(x = prob_target_eot, model, ...)
# Find the dose which gives the maximum gain.
dosegrid_range <- dose_grid_range(data)
opt <- optim(
par = dosegrid_range[1],
fn = function(DOSE) {
- -gain(DOSE, model_dle = model, model_eff = model_eff)
+ -gain(DOSE, model_dle = model, model_eff = model_eff, ...)
},
method = "L-BFGS-B",
lower = dosegrid_range[1],
@@ -986,15 +986,15 @@ setMethod(
# Generate target dose samples, i.e. the doses with probability of the
# occurrence of a DLT that equals to the prob_target_drt or prob_target_eot.
- dose_target_drt_samples <- dose(x = prob_target_drt, model, samples = samples)
- dose_target_eot_samples <- dose(x = prob_target_eot, model, samples = samples)
+ dose_target_drt_samples <- dose(x = prob_target_drt, model, samples = samples, ...)
+ dose_target_eot_samples <- dose(x = prob_target_eot, model, samples = samples, ...)
# Derive the prior/posterior estimates based on two above samples.
dose_target_drt <- nextBest@derive(dose_target_drt_samples)
dose_target_eot <- nextBest@derive(dose_target_eot_samples)
# Gain samples.
- gain_samples <- sapply(data@doseGrid, gain, model, samples, model_eff, samples_eff)
+ gain_samples <- sapply(data@doseGrid, gain, model, samples, model_eff, samples_eff, ...)
# For every sample, get the dose (from the dose grid) that gives the maximum gain value.
dose_lev_mg_samples <- apply(gain_samples, 1, which.max)
dose_mg_samples <- data@doseGrid[dose_lev_mg_samples]
@@ -1085,7 +1085,7 @@ setMethod(
),
definition = function(nextBest, doselimit, samples, model, data, ...) {
# Matrix with samples from the dose-tox curve at the dose grid points.
- prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples)
+ prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)
# Determine the maximum dose level with a toxicity probability below or
# equal to the target and calculate how often a dose is selected as MTD
@@ -1237,7 +1237,7 @@ setMethod(
),
definition = function(nextBest, doselimit, samples, model, data, ...) {
# Matrix with samples from the dose-tox curve at the dose grid points.
- prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples)
+ prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)
# Determine which dose level has the minimum distance to target.
dose_min_mtd_dist <- apply(
@@ -2284,7 +2284,8 @@ setMethod("stopTrial",
mtdSamples <- dose(
x = stopping@target,
model,
- samples
+ samples,
+ ...
)
## what is the absolute threshold?
@@ -2354,7 +2355,8 @@ setMethod(
mtd_samples <- dose(
x = stopping@target,
model,
- samples
+ samples,
+ ...
)
# CV of MTD expressed as percentage, derived based on MTD posterior samples.
mtd_cv <- (mad(mtd_samples) / median(mtd_samples)) * 100
@@ -2459,7 +2461,7 @@ setMethod(
definition = function(stopping, dose, samples, model, data, ...) {
# Compute the target biomarker prob at this dose.
# Get the biomarker level samples at the dose grid points.
- biom_level_samples <- biomarker(xLevel = seq_len(data@nGrid), model, samples)
+ biom_level_samples <- biomarker(xLevel = seq_len(data@nGrid), model, samples, ...)
# If target is relative to maximum.
if (stopping@is_relative) {
@@ -2910,7 +2912,8 @@ setMethod(
dose_target_samples <- dose(
x = stopping@prob_target,
model = model,
- samples = samples
+ samples = samples,
+ ...
)
# 95% credibility interval.
dose_target_ci <- quantile(dose_target_samples, probs = c(0.025, 0.975))
@@ -2955,7 +2958,7 @@ setMethod("stopTrial",
assert_probability(stopping@prob_target)
prob_target <- stopping@prob_target
- dose_target_samples <- dose(x = prob_target, model = model)
+ dose_target_samples <- dose(x = prob_target, model = model, ...)
## Find the variance of the log of the dose_target_samples(eta)
M1 <- matrix(c(-1 / (model@phi2), -(log(prob_target / (1 - prob_target)) - model@phi1) / (model@phi2)^2), 1, 2)
M2 <- model@Pcov
@@ -3024,7 +3027,8 @@ setMethod("stopTrial",
TDtargetEndOfTrialSamples <- dose(
x = prob_target,
model = model,
- samples = samples
+ samples = samples,
+ ...
)
## Find the TDtarget End of trial estimate
TDtargetEndOfTrialEstimate <- TDderive(TDtargetEndOfTrialSamples)
@@ -3047,7 +3051,8 @@ setMethod("stopTrial",
model,
samples,
Effmodel,
- Effsamples
+ Effsamples,
+ ...
)
}
@@ -3137,12 +3142,13 @@ setMethod("stopTrial",
## find the TDtarget End of Trial
TDtargetEndOfTrial <- dose(
x = prob_target,
- model = model
+ model = model,
+ ...
)
## Find the dose with maximum gain value
Gainfun <- function(DOSE) {
- -gain(DOSE, model_dle = model, model_eff = Effmodel)
+ -gain(DOSE, model_dle = model, model_eff = Effmodel, ...)
}
# if(data@placebo) {
diff --git a/R/crmPack-package.R b/R/crmPack-package.R
index 44fbf1ee0..a07ec3797 100644
--- a/R/crmPack-package.R
+++ b/R/crmPack-package.R
@@ -138,7 +138,8 @@ globalVariables(c(
"comp",
"X",
"skel_probs",
- "is_combo"
+ "is_combo",
+ "results"
))
# nolint end
diff --git a/R/helpers_data.R b/R/helpers_data.R
new file mode 100644
index 000000000..a055085dd
--- /dev/null
+++ b/R/helpers_data.R
@@ -0,0 +1,209 @@
+#' Helper Function to Blind Plot Data
+#'
+#' @param df (`GeneralData`)\cr The data to be blinded
+#' @param blind (`flag`)\cr Should the data be blinded?
+#' @param has_placebo (`flag`)\cr Does the data contain a placebo dose?
+#' @param pbo_dose (`positive_number`)\cr The dose to be taken as placebo.
+#' Ignored if `has_placebo` is `FALSE`
+#' @returns The blinded data
+h_blind_plot_data <- function(df, blind, has_placebo, pbo_dose) {
+ if (blind) {
+ # This is to blind the data.
+ # For each cohort, all DLTs are assigned to the first subjects in the cohort.
+ # In addition, the placebo (if any) is set to the active dose level for that
+ # cohort.
+ # Notice: dapply reorders records of df according to the lexicographic order
+ # of cohort.
+ df <- dapply(df, f = ~cohort, FUN = function(coh) {
+ coh$toxicity <- sort(coh$toxicity, decreasing = TRUE)
+ coh$dose <- max(coh$dose)
+ coh
+ })
+ } else if (has_placebo) {
+ # Placebo will be plotted at y = 0 level.
+ df$dose[df$dose == pbo_dose] <- 0
+ }
+ df
+}
+
+# h_plot_data_df ----
+
+## generic ----
+
+#' Helper Function for the Plot Method of subclasses of [`GeneralData`]
+#'
+#' @description `r lifecycle::badge("experimental")`
+#'
+#' A method that transforms [`GeneralData`] objects into a `tibble` suitable for
+#' plotting with `ggplot2` methods
+#'
+#' @param data (`GeneralData`)\cr object from which data is extracted and converted
+#' into a data frame.
+#' @param ... further arguments passed to class-specific methods.
+#' @return `data.frame` containing columns for patient, cohort, dose and toxicity grade
+#' @aliases h_plot_data_df
+#'
+setGeneric(
+ name = "h_plot_data_df",
+ def = function(data, ...) standardGeneric("h_plot_data_df"),
+ valueClass = "data.frame"
+)
+
+# Data ----
+
+#' Helper Function for the Plot Method of [`Data`]
+#'
+#' @param data (`Data`)\cr object from which data is extracted and converted
+#' into a data frame.
+#' @param blind (`flag`)\cr should data be blinded?
+#' If `TRUE`, then for each cohort, all DLTs are assigned to the first
+#' subjects in the cohort. In addition, the placebo (if any) is set to the
+#' active dose level for that cohort.
+#' @param legend (`flag`)\cr Display the legend for the toxicity categories
+#' @param ... further arguments passed to `data.frame` constructor.
+#' It can be e.g. an extra `column_name = value` pair based on a slot
+#' from `x` (which in this case might be a subclass of `Data`)
+#' which does not appear in `Data`.
+#' @return A `data.frame` object with columns patient, ID, cohort, dose and
+#' toxicity.
+#' @describeIn h_plot_data_df method for [`Data`].
+setMethod(
+ f = "h_plot_data_df",
+ signature = signature(data = "Data"),
+ definition = function(data, blind = FALSE, legend = TRUE, ...) {
+ df <- data.frame(
+ patient = seq_along(data@x),
+ ID = paste(" ", data@ID),
+ cohort = data@cohort,
+ dose = data@x,
+ toxicity = ifelse(data@y == 1, "Yes", "No"),
+ ...
+ )
+ df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
+ df
+ }
+)
+
+# DataOrdinal ----
+
+#' Helper Function for the Plot Method of [`DataOrdinal`]
+#'
+#' @describeIn h_plot_data_df Class specific method for [`DataOrdinal`]
+setMethod(
+ f = "h_plot_data_df",
+ signature = signature(data = "DataOrdinal"),
+ definition = function(data, blind = FALSE, legend = TRUE, ...) {
+ df <- data.frame(
+ patient = seq_along(data@x),
+ ID = paste(" ", data@ID),
+ cohort = data@cohort,
+ dose = data@x,
+ toxicity = names(data@yCategories)[1 + data@y],
+ ...
+ )
+ df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
+ df
+ }
+)
+
+
+# h_plot_data_dataordinal
+
+## Data ----
+
+#' Helper Function for the Plot Method of the Data and DataOrdinal Classes
+#'
+#' @description `r lifecycle::badge("stable")`
+#'
+#' A method that creates a plot for [`Data`] and [`DataOrdinal`] objects.
+#'
+#' @note The default values of `tox_shapes` and `tox_labels` result in DLTs
+#' being displayed as red triangles and other responses as black circles.
+#' @return The [`ggplot2`] object.
+#'
+#' @rdname plot-Data
+h_plot_data_dataordinal <- function(
+ x,
+ blind = FALSE,
+ legend = TRUE,
+ tox_labels = c(Yes = "red", No = "black"),
+ tox_shapes = c(Yes = 17L, No = 16L),
+ ...) {
+ assert_flag(blind)
+ assert_flag(legend)
+ assert_character(tox_labels, any.missing = FALSE, unique = TRUE)
+ assert_integer(tox_shapes, any.missing = FALSE, unique = TRUE)
+ assert_true(length(tox_shapes) == length(tox_labels))
+ assert_subset(x@y, as.integer(0:(length(tox_shapes) - 1)))
+ if (x@nObs == 0L) {
+ return()
+ }
+ df <- h_plot_data_df(x, blind, ...)
+
+ p <- ggplot(df, aes(x = patient, y = dose)) +
+ geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +
+ scale_colour_manual(
+ name = "Toxicity",
+ values = tox_labels,
+ breaks = names(tox_labels),
+ guide = guide_legend(reverse = TRUE)
+ ) +
+ scale_shape_manual(
+ name = "Toxicity",
+ values = tox_shapes,
+ breaks = names(tox_shapes),
+ guide = guide_legend(reverse = TRUE)
+ ) +
+ scale_x_continuous(breaks = df$patient, minor_breaks = NULL) +
+ scale_y_continuous(
+ breaks = sort(unique(c(0, df$dose))),
+ minor_breaks = NULL,
+ limits = c(0, max(df$dose) * 1.1)
+ ) +
+ xlab("Patient") +
+ ylab("Dose Level")
+
+ p <- p + h_plot_data_cohort_lines(df$cohort, placebo = x@placebo)
+
+ if (!blind) {
+ p <- p +
+ geom_text(
+ aes(label = ID, size = 2),
+ data = df,
+ hjust = 0,
+ vjust = 0.5,
+ angle = 90,
+ colour = "black",
+ show.legend = FALSE
+ )
+ }
+
+ if (!legend) {
+ p <- p + theme(legend.position = "none")
+ }
+
+ p
+}
+
+#' Helper Function Containing Common Functionality
+#'
+#' Used by `dose_grid_range-Data` and `dose_grid_range-DataOrdinal`
+#' @param object (`Data` or `DataOrdinal`)\cr the object for which the dose grid
+#' range is required
+#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
+#'
+h_obtain_dose_grid_range <- function(object, ignore_placebo) {
+ assert_flag(ignore_placebo)
+
+ dose_grid <- if (ignore_placebo && object@placebo && object@nGrid >= 1) {
+ object@doseGrid[-1]
+ } else {
+ object@doseGrid
+ }
+
+ if (length(dose_grid) == 0L) {
+ c(-Inf, Inf)
+ } else {
+ range(dose_grid)
+ }
+}
diff --git a/R/helpers_design.R b/R/helpers_design.R
new file mode 100644
index 000000000..b30026b78
--- /dev/null
+++ b/R/helpers_design.R
@@ -0,0 +1,168 @@
+#' Helper Function to Set and Save the RNG Seed
+#'
+#' @description `r lifecycle::badge("stable")`
+#'
+#' This code is basically copied from `stats:::simulate.lm`.
+#'
+#' @param seed an object specifying if and how the random number generator
+#' should be initialized ("seeded"). Either `NULL` (default) or an
+#' integer that will be used in a call to [set.seed()] before
+#' simulating the response vectors. If set, the value is saved as the
+#' `seed` slot of the returned object. The default, `NULL` will
+#' not change the random generator state.
+#' @return The integer vector containing the random number generate state will
+#' be returned, in order to call this function with this input to reproduce
+#' the obtained simulation results.
+#'
+#' @export
+set_seed <- function(seed = NULL) {
+ assert_number(seed, null.ok = TRUE)
+
+ if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
+ runif(1)
+ }
+
+ if (is.null(seed)) {
+ get(".Random.seed", envir = .GlobalEnv)
+ } else {
+ seed <- as.integer(seed)
+ r_seed <- get(".Random.seed", envir = .GlobalEnv)
+ # Make sure r_seed exists in parent frame.
+ assign(".r_seed", r_seed, envir = parent.frame())
+ set.seed(seed)
+ # Here we need the r_seed in the parent.frame!
+ do.call(
+ "on.exit",
+ list(quote(assign(".Random.seed", .r_seed, envir = .GlobalEnv))),
+ envir = parent.frame()
+ )
+ structure(seed, kind = as.list(RNGkind()))
+ }
+}
+
+#' Helper Function to Obtain Simulation Results List
+#'
+#' The function `fun` can use variables that are visible to itself.
+#' The names of these variables have to be given in the vector `vars`.
+#'
+#' @param fun (`function`)\cr the simulation function for a single iteration, which takes as
+#' single parameter the iteration index.
+#' @param nsim number of simulations to be conducted.
+#' @param vars names of the variables.
+#' @param parallel should the simulation runs be parallelized across the
+#' clusters of the computer?
+#' @param n_cores how many cores should be used for parallel computing?
+#' @return The list with all simulation results (one iteration corresponds
+#' to one list element).
+#'
+#' @importFrom parallel makeCluster
+#' @importFrom parallelly availableCores
+#' @keywords internal programming
+get_result_list <- function(
+ fun,
+ nsim,
+ vars,
+ parallel,
+ n_cores) {
+ assert_flag(parallel)
+ assert_integerish(n_cores, lower = 1)
+
+ if (!parallel) {
+ lapply(
+ X = seq_len(nsim),
+ FUN = fun
+ )
+ } else {
+ # Process all simulations.
+ cores <- min(
+ safeInteger(n_cores),
+ parallelly::availableCores()
+ )
+
+ # Start the cluster.
+ cl <- parallel::makeCluster(cores)
+
+ # Load the required R package.
+ parallel::clusterEvalQ(cl, {
+ library(crmPack)
+ NULL
+ })
+
+ # Export local variables from the caller environment.
+ # Note: parent.frame() is different from parent.env() which returns
+ # the environment where this function has been defined!
+ parallel::clusterExport(
+ cl = cl,
+ varlist = vars,
+ envir = parent.frame()
+ )
+
+ # Export all global variables.
+ parallel::clusterExport(
+ cl = cl,
+ varlist = ls(.GlobalEnv)
+ )
+
+ # Load user extensions from global options.
+ crmpack_extensions <- getOption("crmpack_extensions")
+ if (is.null(crmpack_extensions) != TRUE) {
+ tryCatch(
+ {
+ parallel::clusterCall(cl, crmpack_extensions)
+ },
+ error = function(e) {
+ stop("Failed to export crmpack_extensions: ", e$message)
+ }
+ )
+ }
+
+ # Do the computations in parallel.
+ res <- parallel::parLapply(
+ cl = cl,
+ X = seq_len(nsim),
+ fun = fun
+ )
+
+ # Stop the cluster.
+ parallel::stopCluster(cl)
+
+ res
+ }
+}
+
+#' Helper Function to Add Randomly Generated DLTs During Simulations
+#'
+#' @param data (`Data`)\cr what data to start from.
+#' @param dose (`number`)\cr current dose.
+#' @param truth (`function`)\cr defines the true probability for a DLT at a dose.
+#' @param cohort_size (`CohortSize`)\cr the cohort size rule to use.
+#' @param first_separate (`flag`)\cr whether the first patient is enrolled separately.
+#'
+#' @return The updated `data`.
+#'
+#' @keywords internal
+h_add_dlts <- function(data,
+ dose,
+ truth,
+ cohort_size,
+ first_separate) {
+ assert_class(data, "Data")
+ assert_number(dose)
+ assert_function(truth)
+ assert_class(cohort_size, "CohortSize")
+ assert_flag(first_separate)
+
+ prob <- truth(dose)
+ size <- size(cohort_size, dose = dose, data = data)
+ dlts <- if (first_separate && size > 1) {
+ first_dlts <- rbinom(n = 1, size = 1, prob = prob)
+ if (first_dlts == 0) {
+ c(first_dlts, rbinom(n = size - 1, size = 1, prob = prob))
+ } else {
+ first_dlts
+ }
+ } else {
+ rbinom(n = size, size = 1, prob = prob)
+ }
+ update(data, x = dose, y = dlts)
+}
diff --git a/_pkgdown.yaml b/_pkgdown.yaml
index 91b3857a8..33dc7e0f6 100644
--- a/_pkgdown.yaml
+++ b/_pkgdown.yaml
@@ -38,6 +38,7 @@ reference:
- GeneralData
- Data
- DataDual
+ - DataOrdinal
- DataParts
- DataMixture
- DataDA
@@ -128,8 +129,10 @@ reference:
- DualDesign
- TDsamplesDesign
- TDDesign
+ - DesignGrouped
- title: Internal Helper Functions
contents:
+ - h_blind_plot_data
- h_doses_unique_per_cohort
- h_all_equivalent
- h_plot_data_df
@@ -163,10 +166,12 @@ reference:
- h_next_best_td_plot
- h_next_best_mg_plot
- h_next_best_mgsamples_plot
+ - h_obtain_dose_grid_range
- h_covr_helpers
- h_default_if_empty
- h_unpack_stopit
- h_calc_report_label_percentage
+ - h_validate_common_data_slots
- title: Internal Validation Functions
contents:
- v_general_data
@@ -260,6 +265,7 @@ reference:
- update-DataParts
- update-DataDual
- update-DataDA
+ - update-DataOrdinal
- getEff
- getEff-DataDual
- ngrid
@@ -434,7 +440,7 @@ reference:
- plotDualResponses
- plotGain
- probit
- - setSeed
+ - set_seed
- show,DualSimulationsSummary-method
- show,GeneralSimulationsSummary-method
- show,PseudoDualSimulationsSummary-method
@@ -448,6 +454,7 @@ reference:
- simulate,RuleDesign-method
- simulate,TDDesign-method
- simulate,TDsamplesDesign-method
+ - simulate-DesignGrouped
- summary,DualSimulations-method
- summary,GeneralSimulations-method
- summary,PseudoDualFlexiSimulations-method
diff --git a/examples/Data-class-DataOrdinal.R b/examples/Data-class-DataOrdinal.R
new file mode 100644
index 000000000..a0dc9f016
--- /dev/null
+++ b/examples/Data-class-DataOrdinal.R
@@ -0,0 +1,9 @@
+DataOrdinal(
+ x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
+ y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
+ ID = 1L:10L,
+ cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
+ doseGrid = c(seq(from = 10, to = 100, by = 10)),
+ yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
+ placebo = FALSE
+)
diff --git a/examples/Data-method-update-DataOrdinal.R b/examples/Data-method-update-DataOrdinal.R
new file mode 100644
index 000000000..c4900b9de
--- /dev/null
+++ b/examples/Data-method-update-DataOrdinal.R
@@ -0,0 +1,13 @@
+# Create some data of class 'DataOrdinal'.
+my_data <- DataOrdinal(
+ x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
+ y = c(0, 0, 0, 0, 0, 0, 1, 0),
+ ID = 1L:8L,
+ cohort = c(1L:5L, 6L, 6L, 6L),
+ doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
+ yCategories = c("No tox" = 0L, "AE" = 1L, "DLT" = 2L)
+)
+
+# Update the data with a new cohort.
+my_data1 <- update(my_data, x = 20, y = c(0L, 1L, 2L))
+my_data1
diff --git a/examples/DataOrdinal-method-dose_grid_range.R b/examples/DataOrdinal-method-dose_grid_range.R
new file mode 100644
index 000000000..f835df39b
--- /dev/null
+++ b/examples/DataOrdinal-method-dose_grid_range.R
@@ -0,0 +1,11 @@
+data <- DataOrdinal(
+ x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
+ y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
+ ID = 1L:10L,
+ cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
+ doseGrid = c(seq(from = 10, to = 100, by = 10)),
+ yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
+ placebo = FALSE
+)
+
+dose_grid_range(data)
diff --git a/examples/DataOrdinal-method-plot.R b/examples/DataOrdinal-method-plot.R
new file mode 100644
index 000000000..bd99ee304
--- /dev/null
+++ b/examples/DataOrdinal-method-plot.R
@@ -0,0 +1,11 @@
+data <- DataOrdinal(
+ x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
+ y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
+ ID = 1L:10L,
+ cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
+ doseGrid = c(seq(from = 10, to = 100, by = 10)),
+ yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
+ placebo = FALSE
+)
+
+plot(data)
diff --git a/examples/DataOrdinal-method-update.R b/examples/DataOrdinal-method-update.R
new file mode 100644
index 000000000..968abc706
--- /dev/null
+++ b/examples/DataOrdinal-method-update.R
@@ -0,0 +1,11 @@
+data <- DataOrdinal(
+ x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
+ y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
+ ID = 1L:10L,
+ cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
+ doseGrid = c(seq(from = 10, to = 100, by = 10)),
+ yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
+ placebo = FALSE
+)
+
+update(data, x = 70, y = c(1L, 2L, 1L))
diff --git a/examples/Design-class-DesignGrouped.R b/examples/Design-class-DesignGrouped.R
new file mode 100644
index 000000000..d116306ca
--- /dev/null
+++ b/examples/Design-class-DesignGrouped.R
@@ -0,0 +1,55 @@
+empty_data <- Data(doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100))
+
+# Initialize the joint model.
+my_model <- LogisticLogNormalGrouped(
+ mean = c(-0.85, 0, 1, 0),
+ cov = diag(1, 4),
+ ref_dose = 56
+)
+
+# Choose the rule for selecting the next dose.
+my_next_best <- NextBestNCRM(
+ target = c(0.2, 0.35),
+ overdose = c(0.35, 1),
+ max_overdose_prob = 0.25
+)
+
+# Choose the rule for the cohort-size.
+my_size1 <- CohortSizeRange(
+ intervals = c(0, 30),
+ cohort_size = c(1, 3)
+)
+my_size2 <- CohortSizeDLT(
+ intervals = c(0, 1),
+ cohort_size = c(1, 3)
+)
+my_size <- maxSize(my_size1, my_size2)
+
+# Choose the rule for stopping.
+my_stopping1 <- StoppingMinCohorts(nCohorts = 3)
+my_stopping2 <- StoppingTargetProb(
+ target = c(0.2, 0.35),
+ prob = 0.5
+)
+my_stopping3 <- StoppingMinPatients(nPatients = 20)
+my_stopping <- (my_stopping1 & my_stopping2) | my_stopping3
+
+# Choose the rule for dose increments.
+my_increments <- IncrementsRelative(
+ intervals = c(0, 20),
+ increments = c(1, 0.33)
+)
+
+# Initialize the design.
+design <- DesignGrouped(
+ model = my_model,
+ mono = Design(
+ model = .DefaultModelLogNormal(), # Ignored.
+ nextBest = my_next_best,
+ stopping = my_stopping,
+ increments = my_increments,
+ cohort_size = my_size,
+ data = empty_data,
+ startingDose = 3
+ )
+)
diff --git a/examples/Design-method-simulate-DesignGrouped.R b/examples/Design-method-simulate-DesignGrouped.R
new file mode 100644
index 000000000..f37b725f3
--- /dev/null
+++ b/examples/Design-method-simulate-DesignGrouped.R
@@ -0,0 +1,74 @@
+# Assemble ingredients for our group design.
+my_stopping <- StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5) |
+ StoppingMinPatients(20) |
+ StoppingMissingDose()
+my_increments <- IncrementsDoseLevels(levels = 3L)
+my_next_best <- NextBestNCRM(
+ target = c(0.2, 0.3),
+ overdose = c(0.3, 1),
+ max_overdose_prob = 0.3
+)
+my_cohort_size <- CohortSizeConst(3)
+empty_data <- Data(doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)))
+my_model <- LogisticLogNormalGrouped(
+ mean = c(-4, -4, -4, -4),
+ cov = diag(rep(6, 4)),
+ ref_dose = 0.1
+)
+
+# Put together the design. Note that if we only specify the mono arm,
+# then the combo arm is having the same settings.
+my_design <- DesignGrouped(
+ model = my_model,
+ mono = Design(
+ model = my_model,
+ stopping = my_stopping,
+ increments = my_increments,
+ nextBest = my_next_best,
+ cohort_size = my_cohort_size,
+ data = empty_data,
+ startingDose = 0.1
+ ),
+ first_cohort_mono_only = TRUE,
+ same_dose = TRUE
+)
+
+# Set up a realistic simulation scenario.
+my_truth <- function(x) plogis(-4 + 0.2 * log(x / 0.1))
+my_combo_truth <- function(x) plogis(-4 + 0.5 * log(x / 0.1))
+matplot(
+ x = empty_data@doseGrid,
+ y = cbind(
+ mono = my_truth(empty_data@doseGrid),
+ combo = my_combo_truth(empty_data@doseGrid)
+ ),
+ type = "l",
+ ylab = "true DLT prob",
+ xlab = "dose"
+)
+legend("topright", c("mono", "combo"), lty = c(1, 2), col = c(1, 2))
+
+# Start the simulations.
+set.seed(123)
+my_sims <- simulate(
+ my_design,
+ nsim = 4, # This should be at least 100 in actual applications.
+ seed = 123,
+ truth = my_truth,
+ combo_truth = my_combo_truth
+)
+
+# Looking at the summary of the simulations:
+mono_sims_sum <- summary(my_sims$mono, truth = my_truth)
+combo_sims_sum <- summary(my_sims$combo, truth = my_combo_truth)
+
+mono_sims_sum
+combo_sims_sum
+
+plot(mono_sims_sum)
+plot(combo_sims_sum)
+
+# Looking at specific simulated trials:
+trial_index <- 1
+plot(my_sims$mono@data[[trial_index]])
+plot(my_sims$combo@data[[trial_index]])
diff --git a/examples/mcmc-DataOrdinal.R b/examples/mcmc-DataOrdinal.R
new file mode 100644
index 000000000..3e83f94ac
--- /dev/null
+++ b/examples/mcmc-DataOrdinal.R
@@ -0,0 +1,11 @@
+data <- DataOrdinal(
+ doseGrid = seq(10, 100, 10),
+ x = c(10, 20, 30, 40, 50, 50, 50),
+ y = c(0L, 0L, 0L, 0L, 0L, 1L, 2L),
+ ID = 1L:7L,
+ cohort = as.integer(c(1:4, 5, 5, 5)),
+ yCategories = c("No Tox" = 0L, "Sub tox AE" = 1L, "DLT" = 2L)
+)
+model <- .DefaultLogisticLogNormalOrdinal()
+options <- McmcOptions(rng_kind = "Mersenne-Twister", rng_seed = 1234567)
+samples <- mcmc(data, model, options)
diff --git a/inst/WORDLIST b/inst/WORDLIST
index b9e74ed2b..0610efa09 100644
--- a/inst/WORDLIST
+++ b/inst/WORDLIST
@@ -76,6 +76,7 @@ customised
DataCombo
DataDual
DataMixture
+DataOrdinal
dataname
datanames
DataParts
@@ -221,6 +222,7 @@ md
mDA
Michielin
MinimalInformative
+minimise
minInfModel
ModelEff
modelled
diff --git a/man/DataOrdinal-class.Rd b/man/DataOrdinal-class.Rd
new file mode 100644
index 000000000..9be68a721
--- /dev/null
+++ b/man/DataOrdinal-class.Rd
@@ -0,0 +1,77 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/Data-class.R
+\docType{class}
+\name{DataOrdinal-class}
+\alias{DataOrdinal-class}
+\alias{.DataOrdinal}
+\alias{DataOrdinal}
+\title{\code{DataOrdinal}}
+\usage{
+DataOrdinal(
+ x = numeric(),
+ y = integer(),
+ ID = integer(),
+ cohort = integer(),
+ doseGrid = numeric(),
+ placebo = FALSE,
+ yCategories = c(`No DLT` = 0L, DLT = 1L),
+ ...
+)
+}
+\arguments{
+\item{x}{(\code{numeric})\cr the doses for the patients.}
+
+\item{y}{(\code{integer})\cr the vector of toxicity events (0 or 1).
+You can also supply \code{numeric} vectors, but these will then be converted to
+\code{integer} internally.}
+
+\item{ID}{(\code{integer})\cr unique patient IDs.
+You can also supply \code{numeric} vectors, but these will then be converted to
+\code{integer} internally.}
+
+\item{cohort}{(\code{integer})\cr the cohort (non-negative sorted) indices.
+You can also supply \code{numeric} vectors, but these will then be converted to
+\code{integer} internally.}
+
+\item{doseGrid}{(\code{numeric})\cr all possible doses.}
+
+\item{placebo}{(\code{flag})\cr if \code{TRUE} the first dose level
+in the \code{doseGrid} is considered as placebo.}
+
+\item{yCategories}{(named \code{integer})\cr the names and codes for the
+toxicity categories used in the data. Category labels are taken from the
+names of the vector. The names of the vector must be unique and its values
+must be sorted and take the values 0, 1, 2, ...}
+
+\item{...}{not used.}
+}
+\description{
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
+
+\code{\link{DataOrdinal}} is a class for ordinal toxicity data.
+It inherits from \code{\link{GeneralData}} and it describes toxicity responses on an
+ordinal rather than binary scale.
+}
+\details{
+The \code{cohort} can be missing if and only if \code{placebo} is equal to
+\code{FALSE}.
+}
+\note{
+This class has been implemented as a sibling of the existing \code{Data} class
+(rather than as a parent or child) to minimise the risk of unintended side
+effects on existing classes and methods.
+
+The default setting for the \code{yCategories} slot replicates the behaviour
+of the existing \code{Data} class.
+}
+\examples{
+DataOrdinal(
+ x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
+ y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
+ ID = 1L:10L,
+ cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
+ doseGrid = c(seq(from = 10, to = 100, by = 10)),
+ yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
+ placebo = FALSE
+)
+}
diff --git a/man/DesignGrouped-class.Rd b/man/DesignGrouped-class.Rd
new file mode 100644
index 000000000..d44ef56eb
--- /dev/null
+++ b/man/DesignGrouped-class.Rd
@@ -0,0 +1,124 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/Design-class.R
+\docType{class}
+\name{DesignGrouped-class}
+\alias{DesignGrouped-class}
+\alias{.DesignGrouped}
+\alias{DesignGrouped}
+\alias{.DefaultDesignGrouped}
+\title{\code{DesignGrouped}}
+\usage{
+DesignGrouped(
+ model,
+ mono,
+ combo = mono,
+ first_cohort_mono_only = TRUE,
+ same_dose = TRUE,
+ ...
+)
+}
+\arguments{
+\item{model}{(\code{LogisticLogNormalGrouped})\cr see slot definition.}
+
+\item{mono}{(\code{Design})\cr see slot definition.}
+
+\item{combo}{(\code{Design})\cr see slot definition.}
+
+\item{first_cohort_mono_only}{(\code{flag})\cr see slot definition.}
+
+\item{same_dose}{(\code{flag})\cr see slot definition.}
+
+\item{...}{not used.}
+}
+\description{
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
+
+\code{\link{DesignGrouped}} combines two \code{\link{Design}} objects: one for the mono and one
+for the combo arm of a joint dose escalation design.
+}
+\details{
+Note that the model slots inside the \code{mono} and \code{combo} parameters
+are ignored (because we don't fit separate regression models for the mono and
+combo arms). Instead, the \code{model} parameter is used to fit a joint regression
+model for the mono and combo arms together.
+}
+\section{Slots}{
+
+\describe{
+\item{\code{model}}{(\code{LogisticLogNormalGrouped})\cr the model to be used, currently only one
+class is allowed.}
+
+\item{\code{mono}}{(\code{Design})\cr defines the dose escalation rules for the mono arm, see
+details.}
+
+\item{\code{combo}}{(\code{Design})\cr defines the dose escalation rules for the combo arm, see
+details.}
+
+\item{\code{first_cohort_mono_only}}{(\code{flag})\cr whether first test one mono agent cohort, and then
+once its DLT data has been collected, we proceed from the second cohort onwards with
+concurrent mono and combo cohorts.}
+
+\item{\code{same_dose}}{(\code{flag})\cr whether the lower dose of the separately determined mono and combo
+doses should be used as the next dose for both mono and combo.}
+}}
+
+\note{
+Typically, end-users will not use the \code{.DefaultDesignGrouped()} function.
+}
+\examples{
+empty_data <- Data(doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100))
+
+# Initialize the joint model.
+my_model <- LogisticLogNormalGrouped(
+ mean = c(-0.85, 0, 1, 0),
+ cov = diag(1, 4),
+ ref_dose = 56
+)
+
+# Choose the rule for selecting the next dose.
+my_next_best <- NextBestNCRM(
+ target = c(0.2, 0.35),
+ overdose = c(0.35, 1),
+ max_overdose_prob = 0.25
+)
+
+# Choose the rule for the cohort-size.
+my_size1 <- CohortSizeRange(
+ intervals = c(0, 30),
+ cohort_size = c(1, 3)
+)
+my_size2 <- CohortSizeDLT(
+ intervals = c(0, 1),
+ cohort_size = c(1, 3)
+)
+my_size <- maxSize(my_size1, my_size2)
+
+# Choose the rule for stopping.
+my_stopping1 <- StoppingMinCohorts(nCohorts = 3)
+my_stopping2 <- StoppingTargetProb(
+ target = c(0.2, 0.35),
+ prob = 0.5
+)
+my_stopping3 <- StoppingMinPatients(nPatients = 20)
+my_stopping <- (my_stopping1 & my_stopping2) | my_stopping3
+
+# Choose the rule for dose increments.
+my_increments <- IncrementsRelative(
+ intervals = c(0, 20),
+ increments = c(1, 0.33)
+)
+
+# Initialize the design.
+design <- DesignGrouped(
+ model = my_model,
+ mono = Design(
+ model = .DefaultModelLogNormal(), # Ignored.
+ nextBest = my_next_best,
+ stopping = my_stopping,
+ increments = my_increments,
+ cohort_size = my_size,
+ data = empty_data,
+ startingDose = 3
+ )
+)
+}
diff --git a/man/dose_grid_range.Rd b/man/dose_grid_range.Rd
index 13b814de2..9168fe104 100644
--- a/man/dose_grid_range.Rd
+++ b/man/dose_grid_range.Rd
@@ -4,11 +4,14 @@
\alias{dose_grid_range}
\alias{dose_grid_range,Data-method}
\alias{dose_grid_range-Data}
+\alias{dose_grid_range,DataOrdinal-method}
\title{Getting the Dose Grid Range}
\usage{
dose_grid_range(object, ...)
\S4method{dose_grid_range}{Data}(object, ignore_placebo = TRUE)
+
+\S4method{dose_grid_range}{DataOrdinal}(object, ignore_placebo = TRUE)
}
\arguments{
\item{object}{(\code{Data})\cr object with dose grid.}
@@ -28,6 +31,8 @@ A function that returns a vector of length two with the minimum and maximum
dose in a grid. It returns \code{c(-Inf, Inf)} if the range cannot be determined,
which happens when the dose grid is empty. User can choose whether the
placebo dose (if any) should be counted or not.
+
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
}
\examples{
my_data <- Data(
@@ -40,4 +45,15 @@ my_data <- Data(
)
dose_grid_range(my_data)
dose_grid_range(my_data, ignore_placebo = FALSE)
+data <- DataOrdinal(
+ x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
+ y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
+ ID = 1L:10L,
+ cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
+ doseGrid = c(seq(from = 10, to = 100, by = 10)),
+ yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
+ placebo = FALSE
+)
+
+dose_grid_range(data)
}
diff --git a/man/getResultList.Rd b/man/getResultList.Rd
deleted file mode 100644
index ab543ad78..000000000
--- a/man/getResultList.Rd
+++ /dev/null
@@ -1,33 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/Design-methods.R
-\name{getResultList}
-\alias{getResultList}
-\title{Helper function to obtain simulation results list}
-\usage{
-getResultList(fun, nsim, vars, parallel = NULL)
-}
-\arguments{
-\item{fun}{the simulation function for a single iteration, which takes as
-single parameter the iteration index}
-
-\item{nsim}{number of simulations to be conducted}
-
-\item{vars}{names of the variables}
-
-\item{parallel}{shall the iterations be parallelized across the cores?
-if NULL, then no parallelization will be done. If scalar positive number,
-then so many cores will be used.}
-}
-\value{
-the list with all simulation results (one iteration corresponds
-to one list element)
-}
-\description{
-The function \code{fun} can use variables that are visible to itself.
-The names of these variables have to given in the vector \code{vars}.
-}
-\author{
-Daniel Sabanes Bove \email{sabanesd@roche.com}
-}
-\keyword{internal}
-\keyword{programming}
diff --git a/man/get_result_list.Rd b/man/get_result_list.Rd
new file mode 100644
index 000000000..e47267ea0
--- /dev/null
+++ b/man/get_result_list.Rd
@@ -0,0 +1,31 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/helpers_design.R
+\name{get_result_list}
+\alias{get_result_list}
+\title{Helper Function to Obtain Simulation Results List}
+\usage{
+get_result_list(fun, nsim, vars, parallel, n_cores)
+}
+\arguments{
+\item{fun}{(\code{function})\cr the simulation function for a single iteration, which takes as
+single parameter the iteration index.}
+
+\item{nsim}{number of simulations to be conducted.}
+
+\item{vars}{names of the variables.}
+
+\item{parallel}{should the simulation runs be parallelized across the
+clusters of the computer?}
+
+\item{n_cores}{how many cores should be used for parallel computing?}
+}
+\value{
+The list with all simulation results (one iteration corresponds
+to one list element).
+}
+\description{
+The function \code{fun} can use variables that are visible to itself.
+The names of these variables have to be given in the vector \code{vars}.
+}
+\keyword{internal}
+\keyword{programming}
diff --git a/man/h_add_dlts.Rd b/man/h_add_dlts.Rd
new file mode 100644
index 000000000..a7809024e
--- /dev/null
+++ b/man/h_add_dlts.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/helpers_design.R
+\name{h_add_dlts}
+\alias{h_add_dlts}
+\title{Helper Function to Add Randomly Generated DLTs During Simulations}
+\usage{
+h_add_dlts(data, dose, truth, cohort_size, first_separate)
+}
+\arguments{
+\item{data}{(\code{Data})\cr what data to start from.}
+
+\item{dose}{(\code{number})\cr current dose.}
+
+\item{truth}{(\code{function})\cr defines the true probability for a DLT at a dose.}
+
+\item{cohort_size}{(\code{CohortSize})\cr the cohort size rule to use.}
+
+\item{first_separate}{(\code{flag})\cr whether the first patient is enrolled separately.}
+}
+\value{
+The updated \code{data}.
+}
+\description{
+Helper Function to Add Randomly Generated DLTs During Simulations
+}
+\keyword{internal}
diff --git a/man/h_blind_plot_data.Rd b/man/h_blind_plot_data.Rd
new file mode 100644
index 000000000..9c27dc3ce
--- /dev/null
+++ b/man/h_blind_plot_data.Rd
@@ -0,0 +1,24 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/helpers_data.R
+\name{h_blind_plot_data}
+\alias{h_blind_plot_data}
+\title{Helper Function to Blind Plot Data}
+\usage{
+h_blind_plot_data(df, blind, has_placebo, pbo_dose)
+}
+\arguments{
+\item{df}{(\code{GeneralData})\cr The data to be blinded}
+
+\item{blind}{(\code{flag})\cr Should the data be blinded?}
+
+\item{has_placebo}{(\code{flag})\cr Does the data contain a placebo dose?}
+
+\item{pbo_dose}{(\code{positive_number})\cr The dose to be taken as placebo.
+Ignored if \code{has_placebo} is \code{FALSE}}
+}
+\value{
+The blinded data
+}
+\description{
+Helper Function to Blind Plot Data
+}
diff --git a/man/h_obtain_dose_grid_range.Rd b/man/h_obtain_dose_grid_range.Rd
new file mode 100644
index 000000000..f64ca622d
--- /dev/null
+++ b/man/h_obtain_dose_grid_range.Rd
@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/helpers_data.R
+\name{h_obtain_dose_grid_range}
+\alias{h_obtain_dose_grid_range}
+\title{Helper Function Containing Common Functionality}
+\usage{
+h_obtain_dose_grid_range(object, ignore_placebo)
+}
+\arguments{
+\item{object}{(\code{Data} or \code{DataOrdinal})\cr the object for which the dose grid
+range is required}
+
+\item{ignore_placebo}{(\code{flag})\cr should placebo dose (if any) not be counted?}
+}
+\description{
+Used by \code{dose_grid_range-Data} and \code{dose_grid_range-DataOrdinal}
+}
diff --git a/man/h_plot_data_df.Rd b/man/h_plot_data_df.Rd
index e3d935b01..8c5a37836 100644
--- a/man/h_plot_data_df.Rd
+++ b/man/h_plot_data_df.Rd
@@ -1,27 +1,42 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/helpers.R
+% Please edit documentation in R/helpers.R, R/helpers_data.R
\name{h_plot_data_df}
\alias{h_plot_data_df}
+\alias{h_plot_data_df,Data-method}
+\alias{h_plot_data_df,DataOrdinal-method}
\title{Preparing Data for Plotting}
\usage{
-h_plot_data_df(data, blind = FALSE, ...)
+h_plot_data_df(data, ...)
+
+h_plot_data_df(data, ...)
+
+\S4method{h_plot_data_df}{Data}(data, blind = FALSE, legend = TRUE, ...)
+
+\S4method{h_plot_data_df}{DataOrdinal}(data, blind = FALSE, legend = TRUE, ...)
}
\arguments{
\item{data}{(\code{Data})\cr object from which data is extracted and converted
into a data frame.}
+\item{...}{further arguments passed to \code{data.frame} constructor.
+It can be e.g. an extra \code{column_name = value} pair based on a slot
+from \code{x} (which in this case might be a subclass of \code{Data})
+which does not appear in \code{Data}.}
+
\item{blind}{(\code{flag})\cr should data be blinded?
If \code{TRUE}, then for each cohort, all DLTs are assigned to the first
subjects in the cohort. In addition, the placebo (if any) is set to the
active dose level for that cohort.}
-\item{...}{further arguments passed to \code{data.frame} constructor.
-It can be e.g. an extra \code{column_name = value} pair based on a slot
-from \code{x} (which in this case might be a subclass of \code{Data})
-which does not appear in \code{Data}.}
+\item{legend}{(\code{flag})\cr Display the legend for the toxicity categories}
}
\value{
A \code{\link{data.frame}} object with values to plot.
+
+\code{data.frame} containing columns for patient, cohort, dose and toxicity grade
+
+A \code{data.frame} object with columns patient, ID, cohort, dose and
+toxicity.
}
\description{
\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
@@ -29,4 +44,16 @@ A \code{\link{data.frame}} object with values to plot.
This helper function prepares a \code{data.frame} object based on \code{Data} class
object. The resulting data frame is used by the plot function for \code{Data}
class objects.
+
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
+
+A method that transforms \code{\link{GeneralData}} objects into a \code{tibble} suitable for
+plotting with \code{ggplot2} methods
}
+\section{Methods (by class)}{
+\itemize{
+\item \code{h_plot_data_df(Data)}: method for \code{\link{Data}}.
+
+\item \code{h_plot_data_df(DataOrdinal)}: Class specific method for \code{\link{DataOrdinal}}
+
+}}
diff --git a/man/h_validate_common_data_slots.Rd b/man/h_validate_common_data_slots.Rd
new file mode 100644
index 000000000..546872555
--- /dev/null
+++ b/man/h_validate_common_data_slots.Rd
@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/Data-validity.R
+\name{h_validate_common_data_slots}
+\alias{h_validate_common_data_slots}
+\title{Helper Function performing validation Common to Data and DataOrdinal}
+\usage{
+h_validate_common_data_slots(object)
+}
+\arguments{
+\item{object}{(\code{Data} or \code{DataOrdinal})\cr the object to be validated}
+}
+\value{
+a \code{Validate} object containing the result of the validation
+}
+\description{
+Helper Function performing validation Common to Data and DataOrdinal
+}
diff --git a/man/nextBest.Rd b/man/nextBest.Rd
index fd438dbfc..b9b730b3d 100644
--- a/man/nextBest.Rd
+++ b/man/nextBest.Rd
@@ -52,7 +52,7 @@ nextBest(nextBest, doselimit, samples, model, data, ...)
\S4method{nextBest}{NextBestTD,numeric,missing,LogisticIndepBeta,Data}(nextBest, doselimit = Inf, model, data, in_sim = FALSE, ...)
-\S4method{nextBest}{NextBestTDsamples,numeric,Samples,LogisticIndepBeta,Data}(nextBest, doselimit = Inf, samples, model, data, ...)
+\S4method{nextBest}{NextBestTDsamples,numeric,Samples,LogisticIndepBeta,Data}(nextBest, doselimit = Inf, samples, model, data, in_sim, ...)
\S4method{nextBest}{NextBestMaxGain,numeric,missing,ModelTox,DataDual}(
nextBest,
diff --git a/man/plot-Data-missing-method.Rd b/man/plot-Data-missing-method.Rd
deleted file mode 100644
index 420c9dd6d..000000000
--- a/man/plot-Data-missing-method.Rd
+++ /dev/null
@@ -1,45 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/Data-methods.R
-\name{plot,Data,missing-method}
-\alias{plot,Data,missing-method}
-\alias{plot-Data}
-\title{Plot Method for the \code{\link{Data}} Class}
-\usage{
-\S4method{plot}{Data,missing}(x, y, blind = FALSE, legend = TRUE, ...)
-}
-\arguments{
-\item{x}{(\code{Data})\cr object we want to plot.}
-
-\item{y}{(\code{missing})\cr missing object, for compatibility with the generic
-function.}
-
-\item{blind}{(\code{flag})\cr indicates whether to blind the data.
-If \code{TRUE}, then placebo subjects are reported at the same level
-as the active dose level in the corresponding cohort,
-and DLTs are always assigned to the first subjects in a cohort.}
-
-\item{legend}{(\code{flag})\cr whether the legend should be added.}
-
-\item{...}{not used.}
-}
-\value{
-The \code{\link{ggplot2}} object.
-}
-\description{
-\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}}
-
-A method that creates a plot for \code{\link{Data}} object.
-}
-\examples{
-# Create some data of class 'Data'.
-my_data <- Data(
- x = c(0.001, 0.1, 0.1, 0.5, 0.001, 3, 3, 0.001, 10, 10, 10),
- y = c(0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0),
- cohort = c(1, 1, 1, 2, 3, 3, 3, 4, 4, 4, 4),
- doseGrid = c(0.001, 0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
- placeb = TRUE
-)
-
-# Plot the data.
-plot(my_data)
-}
diff --git a/man/plot-Data.Rd b/man/plot-Data.Rd
new file mode 100644
index 000000000..049964060
--- /dev/null
+++ b/man/plot-Data.Rd
@@ -0,0 +1,103 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/helpers_data.R, R/Data-methods.R
+\name{h_plot_data_dataordinal}
+\alias{h_plot_data_dataordinal}
+\alias{plot,Data,missing-method}
+\alias{plot-Data}
+\alias{plot,DataOrdinal,missing-method}
+\title{Helper Function for the Plot Method of the Data and DataOrdinal Classes}
+\usage{
+h_plot_data_dataordinal(
+ x,
+ blind = FALSE,
+ legend = TRUE,
+ tox_labels = c(Yes = "red", No = "black"),
+ tox_shapes = c(Yes = 17L, No = 16L),
+ ...
+)
+
+\S4method{plot}{Data,missing}(x, y, blind = FALSE, legend = TRUE, ...)
+
+\S4method{plot}{DataOrdinal,missing}(
+ x,
+ y,
+ blind = FALSE,
+ legend = TRUE,
+ tox_labels = NULL,
+ tox_shapes = NULL,
+ ...
+)
+}
+\arguments{
+\item{x}{(\code{DataOrdinal})\cr object we want to plot.}
+
+\item{blind}{(\code{flag})\cr indicates whether to blind the data.
+If \code{TRUE}, then placebo subjects are reported at the same level
+as the active dose level in the corresponding cohort,
+and DLTs are always assigned to the first subjects in a cohort.}
+
+\item{legend}{(\code{flag})\cr whether the legend should be added.}
+
+\item{tox_labels}{(\verb{named list of character})\cr the labels of the toxicity
+categories.}
+
+\item{tox_shapes}{(\verb{names list of integers})\cr the symbols used to identify
+the toxicity categories.}
+
+\item{...}{not used.}
+
+\item{y}{(\code{missing})\cr missing object, for compatibility with the generic
+function.}
+}
+\value{
+The \code{\link{ggplot2}} object.
+
+The \code{\link{ggplot2}} object.
+
+The \code{\link{ggplot2}} object.
+}
+\description{
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}}
+
+A method that creates a plot for \code{\link{Data}} and \code{\link{DataOrdinal}} objects.
+
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}}
+
+A method that creates a plot for \code{\link{Data}} object.
+
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
+
+A method that creates a plot for \code{\link{DataOrdinal}} object.
+}
+\note{
+The default values of \code{tox_shapes} and \code{tox_labels} result in DLTs
+being displayed as red triangles and other responses as black circles.
+
+With more than 9 toxicity categories, toxicity symbols must be
+specified manually.\cr With more than 5 toxicity categories, toxicity labels
+must be specified manually.
+}
+\examples{
+# Create some data of class 'Data'.
+my_data <- Data(
+ x = c(0.001, 0.1, 0.1, 0.5, 0.001, 3, 3, 0.001, 10, 10, 10),
+ y = c(0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0),
+ cohort = c(1, 1, 1, 2, 3, 3, 3, 4, 4, 4, 4),
+ doseGrid = c(0.001, 0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
+ placeb = TRUE
+)
+
+# Plot the data.
+plot(my_data)
+data <- DataOrdinal(
+ x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
+ y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
+ ID = 1L:10L,
+ cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
+ doseGrid = c(seq(from = 10, to = 100, by = 10)),
+ yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
+ placebo = FALSE
+)
+
+plot(data)
+}
diff --git a/man/setSeed.Rd b/man/setSeed.Rd
deleted file mode 100644
index a2edb14ae..000000000
--- a/man/setSeed.Rd
+++ /dev/null
@@ -1,27 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/Design-methods.R
-\name{setSeed}
-\alias{setSeed}
-\title{Helper function to set and save the RNG seed}
-\usage{
-setSeed(seed = NULL)
-}
-\arguments{
-\item{seed}{an object specifying if and how the random number generator
-should be initialized (\dQuote{seeded}). Either \code{NULL} (default) or an
-integer that will be used in a call to \code{\link{set.seed}} before
-simulating the response vectors. If set, the value is saved as the
-\code{seed} slot of the returned object. The default, \code{NULL} will
-not change the random generator state.}
-}
-\value{
-The RNGstate will be returned, in order to call this function
-with this input to reproduce the obtained simulation results
-}
-\description{
-This is basically copied from simulate.lm
-}
-\author{
-Daniel Sabanes Bove \email{sabanesd@roche.com}
-}
-\keyword{programming}
diff --git a/man/set_seed.Rd b/man/set_seed.Rd
new file mode 100644
index 000000000..982d23bad
--- /dev/null
+++ b/man/set_seed.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/helpers_design.R
+\name{set_seed}
+\alias{set_seed}
+\title{Helper Function to Set and Save the RNG Seed}
+\usage{
+set_seed(seed = NULL)
+}
+\arguments{
+\item{seed}{an object specifying if and how the random number generator
+should be initialized ("seeded"). Either \code{NULL} (default) or an
+integer that will be used in a call to \code{\link[=set.seed]{set.seed()}} before
+simulating the response vectors. If set, the value is saved as the
+\code{seed} slot of the returned object. The default, \code{NULL} will
+not change the random generator state.}
+}
+\value{
+The integer vector containing the random number generate state will
+be returned, in order to call this function with this input to reproduce
+the obtained simulation results.
+}
+\description{
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}}
+
+This code is basically copied from \code{stats:::simulate.lm}.
+}
diff --git a/man/simulate-DADesign-method.Rd b/man/simulate-DADesign-method.Rd
index f16f5941d..c81112674 100644
--- a/man/simulate-DADesign-method.Rd
+++ b/man/simulate-DADesign-method.Rd
@@ -28,7 +28,7 @@ data from}
\item{nsim}{the number of simulations (default: 1)}
-\item{seed}{see \code{\link{setSeed}}}
+\item{seed}{see \code{\link{set_seed}}}
\item{truthTox}{a function which takes as input a dose (vector) and returns the
true probability (vector) for toxicity and the time DLT occurs. Additional
diff --git a/man/simulate-Design-method.Rd b/man/simulate-Design-method.Rd
index 86608ab90..7ae3261f0 100644
--- a/man/simulate-Design-method.Rd
+++ b/man/simulate-Design-method.Rd
@@ -24,7 +24,7 @@ data from}
\item{nsim}{the number of simulations (default: 1)}
-\item{seed}{see \code{\link{setSeed}}}
+\item{seed}{see \code{\link{set_seed}}}
\item{truth}{a function which takes as input a dose (vector) and returns the
true probability (vector) for toxicity. Additional arguments can be supplied
diff --git a/man/simulate-DesignGrouped-method.Rd b/man/simulate-DesignGrouped-method.Rd
new file mode 100644
index 000000000..54c2c4880
--- /dev/null
+++ b/man/simulate-DesignGrouped-method.Rd
@@ -0,0 +1,136 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/Design-methods.R
+\name{simulate,DesignGrouped-method}
+\alias{simulate,DesignGrouped-method}
+\alias{simulate-DesignGrouped}
+\title{Simulate Method for the \code{\link{DesignGrouped}} Class}
+\usage{
+\S4method{simulate}{DesignGrouped}(
+ object,
+ nsim = 1L,
+ seed = NULL,
+ truth,
+ combo_truth,
+ args = data.frame(),
+ firstSeparate = FALSE,
+ mcmcOptions = McmcOptions(),
+ parallel = FALSE,
+ nCores = min(parallelly::availableCores(), 5),
+ ...
+)
+}
+\arguments{
+\item{object}{(\code{DesignGrouped})\cr the design we want to simulate trials from.}
+
+\item{nsim}{(\code{number})\cr how many trials should be simulated.}
+
+\item{seed}{(\code{RNGstate})\cr generated with \code{\link[=set_seed]{set_seed()}}.}
+
+\item{truth}{(\code{function})\cr a function which takes as input a dose (vector) and
+returns the true probability (vector) for toxicity for the mono arm.
+Additional arguments can be supplied in \code{args}.}
+
+\item{combo_truth}{(\code{function})\cr same as \code{truth} but for the combo arm.}
+
+\item{args}{(\code{data.frame})\cr optional \code{data.frame} with arguments that work
+for both the \code{truth} and \code{combo_truth} functions. The column names correspond to
+the argument names, the rows to the values of the arguments. The rows are
+appropriately recycled in the \code{nsim} simulations.}
+
+\item{firstSeparate}{(\code{flag})\cr whether to enroll the first patient separately
+from the rest of the cohort and close the cohort in case a DLT occurs in this
+first patient.}
+
+\item{mcmcOptions}{(\code{McmcOptions})\cr MCMC options for each evaluation in the trial.}
+
+\item{parallel}{(\code{flag})\cr whether the simulation runs are parallelized across the
+cores of the computer.}
+
+\item{nCores}{(\code{number})\cr how many cores should be used for parallel computing.}
+
+\item{...}{not used.}
+}
+\value{
+A list of \code{mono} and \code{combo} simulation results as \code{\link{Simulations}} objects.
+}
+\description{
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
+
+A simulate method for \code{\link{DesignGrouped}} designs.
+}
+\examples{
+# Assemble ingredients for our group design.
+my_stopping <- StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5) |
+ StoppingMinPatients(20) |
+ StoppingMissingDose()
+my_increments <- IncrementsDoseLevels(levels = 3L)
+my_next_best <- NextBestNCRM(
+ target = c(0.2, 0.3),
+ overdose = c(0.3, 1),
+ max_overdose_prob = 0.3
+)
+my_cohort_size <- CohortSizeConst(3)
+empty_data <- Data(doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)))
+my_model <- LogisticLogNormalGrouped(
+ mean = c(-4, -4, -4, -4),
+ cov = diag(rep(6, 4)),
+ ref_dose = 0.1
+)
+
+# Put together the design. Note that if we only specify the mono arm,
+# then the combo arm is having the same settings.
+my_design <- DesignGrouped(
+ model = my_model,
+ mono = Design(
+ model = my_model,
+ stopping = my_stopping,
+ increments = my_increments,
+ nextBest = my_next_best,
+ cohort_size = my_cohort_size,
+ data = empty_data,
+ startingDose = 0.1
+ ),
+ first_cohort_mono_only = TRUE,
+ same_dose = TRUE
+)
+
+# Set up a realistic simulation scenario.
+my_truth <- function(x) plogis(-4 + 0.2 * log(x / 0.1))
+my_combo_truth <- function(x) plogis(-4 + 0.5 * log(x / 0.1))
+matplot(
+ x = empty_data@doseGrid,
+ y = cbind(
+ mono = my_truth(empty_data@doseGrid),
+ combo = my_combo_truth(empty_data@doseGrid)
+ ),
+ type = "l",
+ ylab = "true DLT prob",
+ xlab = "dose"
+)
+legend("topright", c("mono", "combo"), lty = c(1, 2), col = c(1, 2))
+
+# Start the simulations.
+set.seed(123)
+my_sims <- simulate(
+ my_design,
+ nsim = 4, # This should be at least 100 in actual applications.
+ seed = 123,
+ truth = my_truth,
+ combo_truth = my_combo_truth
+)
+
+# Looking at the summary of the simulations:
+mono_sims_sum <- summary(my_sims$mono, truth = my_truth)
+combo_sims_sum <- summary(my_sims$combo, truth = my_combo_truth)
+
+mono_sims_sum
+combo_sims_sum
+
+plot(mono_sims_sum)
+plot(combo_sims_sum)
+
+# Looking at specific simulated trials:
+trial_index <- 1
+plot(my_sims$mono@data[[trial_index]])
+plot(my_sims$combo@data[[trial_index]])
+}
diff --git a/man/simulate-DualDesign-method.Rd b/man/simulate-DualDesign-method.Rd
index 16466562a..4de120c6e 100644
--- a/man/simulate-DualDesign-method.Rd
+++ b/man/simulate-DualDesign-method.Rd
@@ -27,7 +27,7 @@ data from}
\item{nsim}{the number of simulations (default: 1)}
-\item{seed}{see \code{\link{setSeed}}}
+\item{seed}{see \code{\link{set_seed}}}
\item{trueTox}{a function which takes as input a dose (vector) and returns the
true probability (vector) for toxicity. Additional arguments can be supplied
diff --git a/man/simulate-DualResponsesDesign-method.Rd b/man/simulate-DualResponsesDesign-method.Rd
index c17e2e58a..6f142be48 100644
--- a/man/simulate-DualResponsesDesign-method.Rd
+++ b/man/simulate-DualResponsesDesign-method.Rd
@@ -27,7 +27,7 @@ process}
\item{nsim}{the number of simulations (default :1)}
-\item{seed}{see \code{\link{setSeed}}}
+\item{seed}{see \code{\link{set_seed}}}
\item{trueDLE}{a function which takes as input a dose (vector) and returns the true probability
(vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.}
diff --git a/man/simulate-DualResponsesSamplesDesign-method.Rd b/man/simulate-DualResponsesSamplesDesign-method.Rd
index 9a842792f..ba46d32af 100644
--- a/man/simulate-DualResponsesSamplesDesign-method.Rd
+++ b/man/simulate-DualResponsesSamplesDesign-method.Rd
@@ -34,7 +34,7 @@ simulate the data from}
\item{nsim}{the number of simulations (default :1)}
-\item{seed}{see \code{\link{setSeed}}}
+\item{seed}{see \code{\link{set_seed}}}
\item{trueDLE}{a function which takes as input a dose (vector) and returns the true probability
(vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.}
diff --git a/man/simulate-RuleDesign-method.Rd b/man/simulate-RuleDesign-method.Rd
index 2aa8f6b08..336c475d1 100644
--- a/man/simulate-RuleDesign-method.Rd
+++ b/man/simulate-RuleDesign-method.Rd
@@ -21,7 +21,7 @@ data from}
\item{nsim}{the number of simulations (default: 1)}
-\item{seed}{see \code{\link{setSeed}}}
+\item{seed}{see \code{\link{set_seed}}}
\item{truth}{a function which takes as input a dose (vector) and returns the
true probability (vector) for toxicity. Additional arguments can be supplied
diff --git a/man/simulate-TDDesign-method.Rd b/man/simulate-TDDesign-method.Rd
index cc5d90f28..e77b2de48 100644
--- a/man/simulate-TDDesign-method.Rd
+++ b/man/simulate-TDDesign-method.Rd
@@ -23,7 +23,7 @@ This is a method based on the \code{\linkS4class{TDDesign}} where model used are
\item{nsim}{the number of simulations (default :1)}
-\item{seed}{see \code{\link{setSeed}}}
+\item{seed}{see \code{\link{set_seed}}}
\item{truth}{a function which takes as input a dose (vector) and returns the true probability
(vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.}
diff --git a/man/simulate-TDsamplesDesign-method.Rd b/man/simulate-TDsamplesDesign-method.Rd
index 9577f36c0..2b3e0d109 100644
--- a/man/simulate-TDsamplesDesign-method.Rd
+++ b/man/simulate-TDsamplesDesign-method.Rd
@@ -24,7 +24,7 @@ This is a method based on the \code{\linkS4class{TDsamplesDesign}} where model u
\item{nsim}{the number of simulations (default :1)}
-\item{seed}{see \code{\link{setSeed}}}
+\item{seed}{see \code{\link{set_seed}}}
\item{truth}{a function which takes as input a dose (vector) and returns the true probability
(vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.}
diff --git a/man/update-Data-method.Rd b/man/update-Data-method.Rd
index ad6e6d75e..84581aa2d 100644
--- a/man/update-Data-method.Rd
+++ b/man/update-Data-method.Rd
@@ -32,16 +32,7 @@ You can also supply \code{numeric} vectors, but these will then be converted to
to a new cohort.}
\item{check}{(\code{flag})\cr whether the validation of the updated object should
-be conducted. Current implementation of this \code{update} method allows for
-updating the \code{Data} class object by adding a single dose level \code{x} only.
-However, there might be some use cases where the new cohort to be added
-contains a placebo and active dose. Hence, such update would need to be
-performed iteratively by calling the \code{update} method twice. For example,
-in the first call a user can add a placebo, and then in the second call,
-an active dose. Since having a cohort with placebo only is not allowed,
-the \code{update} method would normally throw the error when attempting to add
-a placebo in the first call. To allow for such updates, the \code{check}
-parameter should be then set to \code{FALSE} for that first call.}
+be conducted. See details below.}
\item{...}{not used.}
}
@@ -53,6 +44,18 @@ The new, updated \code{\link{Data}} object.
A method that updates existing \code{\link{Data}} object with new data.
}
+\details{
+The current implementation of this \code{update} method allows for
+updating the \code{Data} class object by adding a single dose level \code{x} only.
+However, there might be some use cases where the new cohort to be added
+contains a placebo and active dose. Hence, such update would need to be
+performed iteratively by calling the \code{update} method twice. For example,
+in the first call a user can add a placebo, and then in the second call,
+an active dose. Since having a cohort with placebo only is not allowed,
+the \code{update} method would normally throw the error when attempting to add
+a placebo in the first call. To allow for such updates, the \code{check}
+parameter should be then set to \code{FALSE} for that first call.
+}
\examples{
# Create some data of class 'Data'.
my_data <- Data(
diff --git a/man/update-DataOrdinal-method.Rd b/man/update-DataOrdinal-method.Rd
new file mode 100644
index 000000000..eb6677adb
--- /dev/null
+++ b/man/update-DataOrdinal-method.Rd
@@ -0,0 +1,71 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/Data-methods.R
+\name{update,DataOrdinal-method}
+\alias{update,DataOrdinal-method}
+\alias{update-DataOrdinal}
+\title{Updating \code{DataOrdinal} Objects}
+\usage{
+\S4method{update}{DataOrdinal}(
+ object,
+ x,
+ y,
+ ID = length(object@ID) + seq_along(y),
+ new_cohort = TRUE,
+ check = TRUE,
+ ...
+)
+}
+\arguments{
+\item{object}{(\code{DataOrdinal})\cr object you want to update.}
+
+\item{x}{(\code{number})\cr the dose level (one level only!).}
+
+\item{y}{(\code{integer})\cr the vector of toxicity grades (0, 1, 2, ...) for all
+patients in this cohort. You can also supply \code{numeric} vectors, but these
+will then be converted to \code{integer} internally.}
+
+\item{ID}{(\code{integer})\cr the patient IDs.
+You can also supply \code{numeric} vectors, but these will then be converted to
+\code{integer} internally.}
+
+\item{new_cohort}{(\code{flag})\cr if \code{TRUE} (default) the new data are assigned
+to a new cohort.}
+
+\item{check}{(\code{flag})\cr whether the validation of the updated object should
+be conducted. See Details below.}
+
+\item{...}{not used.}
+}
+\value{
+The new, updated \code{\link{DataOrdinal}} object.
+}
+\description{
+\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
+
+A method that updates existing \code{\link{DataOrdinal}} object with new data.
+}
+\details{
+The current implementation of this \code{update} method allows for
+updating the \code{DataOrdinal} class object by adding a single dose level \code{x} only.
+However, there might be some use cases where the new cohort to be added
+contains a placebo and active dose. Hence, such update would need to be
+performed iteratively by calling the \code{update} method twice. For example,
+in the first call a user can add a placebo, and then in the second call,
+an active dose. Since having a cohort with placebo only is not allowed,
+the \code{update} method would normally throw the error when attempting to add
+a placebo in the first call. To allow for such updates, the \code{check}
+parameter should be then set to \code{FALSE} for that first call.
+}
+\examples{
+data <- DataOrdinal(
+ x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
+ y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
+ ID = 1L:10L,
+ cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
+ doseGrid = c(seq(from = 10, to = 100, by = 10)),
+ yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
+ placebo = FALSE
+)
+
+update(data, x = 70, y = c(1L, 2L, 1L))
+}
diff --git a/man/v_data_objects.Rd b/man/v_data_objects.Rd
index f3958cbd1..c3f3d1f83 100644
--- a/man/v_data_objects.Rd
+++ b/man/v_data_objects.Rd
@@ -9,6 +9,7 @@
\alias{v_data_parts}
\alias{v_data_mixture}
\alias{v_data_da}
+\alias{v_data_ordinal}
\alias{v_data_grouped}
\title{Internal Helper Functions for Validation of \code{\link{GeneralData}} Objects}
\usage{
@@ -26,6 +27,8 @@ v_data_mixture(object)
v_data_da(object)
+v_data_ordinal(object)
+
v_data_grouped(object)
}
\arguments{
@@ -71,6 +74,9 @@ contains valid elements with respect to their types, dependency and length.
\item \code{v_data_da()}: validates that the \code{\link{DataDA}} object
contains valid elements with respect to their types, dependency and length.
+\item \code{v_data_ordinal()}: validates that the \code{\link{DataOrdinal}} object
+contains valid elements with respect to their types, dependency and length.
+
\item \code{v_data_grouped()}: validates that the \code{\link{DataGrouped}} object
contains valid group information.
diff --git a/man/v_design.Rd b/man/v_design.Rd
index c77e39a5c..8f00076d7 100644
--- a/man/v_design.Rd
+++ b/man/v_design.Rd
@@ -3,9 +3,12 @@
\name{v_design}
\alias{v_design}
\alias{v_rule_design}
+\alias{v_design_grouped}
\title{Internal Helper Functions for Validation of \code{\link{RuleDesign}} Objects}
\usage{
v_rule_design(object)
+
+v_design_grouped(object)
}
\arguments{
\item{object}{(\code{RuleDesign})\cr object to validate.}
@@ -25,4 +28,7 @@ These functions are only used internally to validate the format of an input
\item \code{v_rule_design()}: validates that the \code{\link{RuleDesign}} object
contains valid \code{startingDose}.
+\item \code{v_design_grouped()}: validates that the \code{\link{DesignGrouped}} object
+contains valid flags.
+
}}
diff --git a/tests/testthat/_snaps/Data-methods/plot-dataordinal-placebo-blinding-nolegend.svg b/tests/testthat/_snaps/Data-methods/plot-dataordinal-placebo-blinding-nolegend.svg
new file mode 100644
index 000000000..0a786ef7f
--- /dev/null
+++ b/tests/testthat/_snaps/Data-methods/plot-dataordinal-placebo-blinding-nolegend.svg
@@ -0,0 +1,98 @@
+
+
diff --git a/tests/testthat/_snaps/Data-methods/plot-dataordinal-placebo-blinding.svg b/tests/testthat/_snaps/Data-methods/plot-dataordinal-placebo-blinding.svg
new file mode 100644
index 000000000..c3c5b872c
--- /dev/null
+++ b/tests/testthat/_snaps/Data-methods/plot-dataordinal-placebo-blinding.svg
@@ -0,0 +1,92 @@
+
+
diff --git a/tests/testthat/_snaps/Data-methods/plot-dataordinal-placebo.svg b/tests/testthat/_snaps/Data-methods/plot-dataordinal-placebo.svg
new file mode 100644
index 000000000..51229c0fd
--- /dev/null
+++ b/tests/testthat/_snaps/Data-methods/plot-dataordinal-placebo.svg
@@ -0,0 +1,102 @@
+
+
diff --git a/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo-and-blinding.svg b/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo-and-blinding.svg
index 2d942cc29..2c7732976 100644
--- a/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo-and-blinding.svg
+++ b/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo-and-blinding.svg
@@ -25,83 +25,83 @@
-
+
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-0
-25
-50
-100
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-1
-2
-3
-4
-5
-6
-7
-8
-9
-10
-11
-12
-Patient
-Dose Level
+0
+25
+50
+100
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+1
+2
+3
+4
+5
+6
+7
+8
+9
+10
+11
+12
+Patient
+Dose Level
@@ -114,118 +114,118 @@
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-1
-2
-3
-4
-5
-6
-7
-8
-9
-10
-11
-12
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-0
-50
-100
-150
-Time
-Patient
-
-Toxicity
-
-
-
-
-
-
-
-
-
-No
-Start
-Yes
+1
+2
+3
+4
+5
+6
+7
+8
+9
+10
+11
+12
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+0
+50
+100
+150
+Time
+Patient
+
+Toxicity
+
+
+
+
+
+
+
+
+
+No
+Start
+Yes
diff --git a/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo.svg b/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo.svg
index cfee7cc27..6ac24bf1a 100644
--- a/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo.svg
+++ b/tests/testthat/_snaps/Data-methods/plot-of-datada-with-placebo.svg
@@ -25,95 +25,95 @@
-
+
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- 1
- 2
- 3
- 4
- 5
- 6
- 7
- 8
- 9
- 10
- 11
- 12
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+ 10
+ 11
+ 12
-0
-25
-50
-100
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-1
-2
-3
-4
-5
-6
-7
-8
-9
-10
-11
-12
-Patient
-Dose Level
+0
+25
+50
+100
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+1
+2
+3
+4
+5
+6
+7
+8
+9
+10
+11
+12
+Patient
+Dose Level
@@ -126,130 +126,130 @@
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- 1
- 2
- 3
- 4
- 5
- 6
- 7
- 8
- 9
- 10
- 11
- 12
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+ 10
+ 11
+ 12
-1
-2
-3
-4
-5
-6
-7
-8
-9
-10
-11
-12
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-0
-50
-100
-150
-Time
-Patient
-
-Toxicity
-
-
-
-
-
-
-
-
-
-No
-Start
-Yes
+1
+2
+3
+4
+5
+6
+7
+8
+9
+10
+11
+12
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+0
+50
+100
+150
+Time
+Patient
+
+Toxicity
+
+
+
+
+
+
+
+
+
+No
+Start
+Yes
diff --git a/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo-and-blinding.svg b/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo-and-blinding.svg
index 19a028ef9..9e13fae7c 100644
--- a/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo-and-blinding.svg
+++ b/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo-and-blinding.svg
@@ -30,78 +30,78 @@
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-0
-25
-50
-100
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-1
-2
-3
-4
-5
-6
-7
-8
-9
-10
-11
-12
-Patient
-Dose Level
+0
+25
+50
+100
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+1
+2
+3
+4
+5
+6
+7
+8
+9
+10
+11
+12
+Patient
+Dose Level
@@ -114,67 +114,67 @@
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-25
-50
-75
-100
-
-
-
-
-
-
-
-
-40
-60
-80
-100
-Dose Level
-Biomarker
-
-Toxicity
-
-
-
-
-No
-Yes
+25
+50
+75
+100
+
+
+
+
+
+
+
+
+40
+60
+80
+100
+Dose Level
+Biomarker
+
+Toxicity
+
+
+
+
+No
+Yes
diff --git a/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo.svg b/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo.svg
index 4e826e4ce..faf2ae9b0 100644
--- a/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo.svg
+++ b/tests/testthat/_snaps/Data-methods/plot-of-datadual-with-placebo.svg
@@ -30,90 +30,90 @@
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- 1
- 2
- 3
- 4
- 5
- 6
- 7
- 8
- 9
- 10
- 11
- 12
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+ 10
+ 11
+ 12
-0
-25
-50
-100
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-1
-2
-3
-4
-5
-6
-7
-8
-9
-10
-11
-12
-Patient
-Dose Level
+0
+25
+50
+100
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+1
+2
+3
+4
+5
+6
+7
+8
+9
+10
+11
+12
+Patient
+Dose Level
@@ -126,82 +126,82 @@
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-1
-2
-3
-4
-5
-6
-7
-8
-9
-10
-11
-12
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+1
+2
+3
+4
+5
+6
+7
+8
+9
+10
+11
+12
-25
-50
-75
-100
-
-
-
-
-
-
-
-
-
-0
-25
-50
-75
-100
-Dose Level
-Biomarker
-
-Toxicity
-
-
-
-
-No
-Yes
+25
+50
+75
+100
+
+
+
+
+
+
+
+
+
+0
+25
+50
+75
+100
+Dose Level
+Biomarker
+
+Toxicity
+
+
+
+
+No
+Yes
diff --git a/tests/testthat/helper-data.R b/tests/testthat/helper-data.R
index a9ce8a03f..4819ea624 100644
--- a/tests/testthat/helper-data.R
+++ b/tests/testthat/helper-data.R
@@ -162,6 +162,19 @@ h_get_data_sr_2 <- function() {
)
}
+# Sample ordinal data ----
+h_get_data_ordinal <- function() {
+ DataOrdinal(
+ x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
+ y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
+ ID = 1L:10L,
+ cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
+ doseGrid = c(seq(from = 10, to = 100, by = 10)),
+ yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
+ placebo = FALSE
+ )
+}
+
# DataGrouped ----
h_get_data_grouped <- function(empty = FALSE, placebo = TRUE) {
diff --git a/tests/testthat/helper-model.R b/tests/testthat/helper-model.R
index e1725a900..b56e23665 100644
--- a/tests/testthat/helper-model.R
+++ b/tests/testthat/helper-model.R
@@ -386,22 +386,3 @@ h_get_fractional_crm <- function() {
sigma2 = 2
)
}
-
-.NeedsExtraProbModel <- setClass("NeedsExtraProbModel", contains = "LogisticKadane")
-setMethod(
- f = "prob",
- signature = signature(
- dose = "numeric",
- model = "NeedsExtraProbModel",
- samples = "Samples"
- ),
- definition = function(dose, model, samples, extra_argument) {
- if (missing(extra_argument)) stop("we need extra_argument")
- # We don't forward to LogisticKadane method here since that would
- # not accept the extra argument.
- rep(0.5, size(samples))
- }
-)
-h_needs_extra_prob_model <- function() {
- .NeedsExtraProbModel(h_get_logistic_kadane())
-}
diff --git a/tests/testthat/test-Data-class.R b/tests/testthat/test-Data-class.R
index c8c83bc42..19c0b3c64 100644
--- a/tests/testthat/test-Data-class.R
+++ b/tests/testthat/test-Data-class.R
@@ -186,6 +186,37 @@ test_that("DataDA object can be created with custom values", {
expect_valid(result, "DataDA")
})
+# DataOrdinal-class ----
+
+test_that(".DataOrdinal works as expected", {
+ result <- expect_silent(.DataOrdinal())
+ expect_valid(result, "DataOrdinal")
+})
+
+# DataOrdinal-constructor ----
+
+test_that("DataOrdinal object can be created with user constructor DataOrdinal", {
+ result <- expect_silent(DataOrdinal())
+ expect_valid(result, "DataOrdinal")
+})
+
+test_that("DataOrdinal object can be created with custom values", {
+ result <- expect_silent(
+ DataOrdinal(
+ u = c(42, 30, 15),
+ t0 = c(0, 15, 30),
+ Tmax = 60,
+ x = c(0.1, 0.5, 1.5),
+ y = c(0, 0, 0),
+ ID = 1:3,
+ cohort = 1:3,
+ doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
+ yCategories = c("Cat 0" = 0L, "Cat 1" = 1L, "Cat 2" = 2L)
+ )
+ )
+ expect_valid(result, "DataOrdinal")
+})
+
# DataGrouped-class ----
test_that(".DataGrouped works as expected", {
diff --git a/tests/testthat/test-Data-methods.R b/tests/testthat/test-Data-methods.R
index c386c09fd..41f917ce2 100644
--- a/tests/testthat/test-Data-methods.R
+++ b/tests/testthat/test-Data-methods.R
@@ -59,6 +59,30 @@ test_that("Plot works for DataDA object with placebo and blinding", {
)
})
+# plot-DataOrdinal ----
+
+test_that("Plot works as expected for DataOrdinal object with placebo", {
+ data <- h_get_data_ordinal()
+ result <- plot(data)
+
+ vdiffr::expect_doppelganger("plot-DataOrdinal-placebo", result)
+})
+
+test_that("Plot works as expected for DataOrdinal object with placebo and blinding", {
+ data <- h_get_data_ordinal()
+ result <- plot(data, blind = TRUE)
+
+ vdiffr::expect_doppelganger("plot-DataOrdinal-placebo-blinding", result)
+})
+
+test_that("Plot works for DataOrdinal object with placebo, blinding and no legend", {
+ data <- h_get_data()
+ result <- plot(data, blind = TRUE, legend = FALSE)
+
+ vdiffr::expect_doppelganger("plot-DataOrdinal-placebo-blinding-nolegend", result)
+})
+
+
# update-Data ----
test_that("Update of Data works as expected", {
@@ -125,6 +149,71 @@ test_that("Update of Data, no error for non-valid update and validation off", {
)
})
+# update-DataOrdinal
+test_that("Update of Data works as expected", {
+ object <- h_get_data()
+ result <- update(object, x = 25, y = c(0L, 1L, 1L))
+
+ object@x <- c(object@x, 25, 25, 25)
+ object@y <- c(object@y, 0L, 1L, 1L)
+ object@nObs <- object@nObs + 3L
+ object@ID <- c(object@ID, 13L, 14L, 15L)
+ object@xLevel <- c(object@xLevel, 2L, 2L, 2L)
+ object@cohort <- c(object@cohort, 4L, 4L, 4L)
+
+ expect_valid(result, "Data")
+ expect_identical(result, object)
+})
+
+test_that("Update of empty DataOrdinal works as expected", {
+ object <- DataOrdinal(
+ x = c(25, 25), y = c(0L, 1L), doseGrid = 25, ID = 1:2, cohort = c(1L, 1L)
+ )
+ result <- update(DataOrdinal(doseGrid = 25), x = 25, y = c(0L, 1L))
+
+ expect_valid(result, "DataOrdinal")
+ expect_identical(result, object)
+})
+
+test_that("Update of DataOrdinal works for 'empty' update", {
+ object <- h_get_data_ordinal()
+ result <- update(object, x = numeric(0), y = integer(0))
+ expect_identical(result, object)
+})
+
+test_that("Update of DataOrdinal works when doses are added to the old cohort", {
+ object <- h_get_data_ordinal()
+ result <- update(object, x = 60, y = c(0L, 1L, 2L), new_cohort = FALSE)
+
+ object@x <- c(object@x, 60, 60, 60)
+ object@y <- c(object@y, 0L, 1L, 2L)
+ object@nObs <- object@nObs + 3L
+ object@ID <- c(object@ID, 11L, 12L, 13L)
+ object@xLevel <- c(object@xLevel, 6L, 6L, 6L)
+ object@cohort <- c(object@cohort, 6L, 6L, 6L)
+
+ expect_valid(result, "DataOrdinal")
+ expect_identical(result, object)
+})
+
+test_that("Update of DataOrdinal throws the error for a dose x out of the grid", {
+ object <- h_get_data_ordinal()
+ expect_error(
+ update(object, x = 12345, y = c(0L, 1L, 1L), new_cohort = FALSE),
+ ".*Dose values in x must be from doseGrid.*"
+ )
+})
+
+test_that("Update of DataOrdinal, no error for non-valid update and validation off", {
+ object <- h_get_data_ordinal()
+ expect_silent(
+ update(
+ object,
+ x = 12345, y = c(0L, 1L, 1L), new_cohort = FALSE, check = FALSE
+ )
+ )
+})
+
# update-DataParts ----
test_that("Update of DataParts works as expected", {
@@ -479,3 +568,42 @@ test_that("dose_grid_range-Data works as expected without placebo in grid", {
expect_identical(dose_grid_range(data_empty), c(-Inf, Inf))
expect_identical(dose_grid_range(data_empty, FALSE), c(-Inf, Inf))
})
+
+## DataOrdinal ----
+
+test_that("dose_grid_range-DataOrdinal works as expected with placebo in grid", {
+ data <- h_get_data_ordinal()
+ expect_identical(dose_grid_range(data), c(10, 100))
+ expect_identical(dose_grid_range(data, FALSE), c(10, 100))
+
+ data_1 <- DataOrdinal(doseGrid = c(0.001, 25), placebo = TRUE)
+ expect_identical(dose_grid_range(data_1), c(25, 25))
+ expect_identical(dose_grid_range(data_1, FALSE), c(0.001, 25))
+
+ data_2 <- DataOrdinal(doseGrid = 0.001, placebo = TRUE)
+ expect_identical(dose_grid_range(data_2), c(-Inf, Inf))
+ expect_identical(dose_grid_range(data_2, FALSE), c(0.001, 0.001))
+
+ data_empty <- DataOrdinal(placebo = TRUE)
+ expect_identical(dose_grid_range(data_empty), c(-Inf, Inf))
+ expect_identical(dose_grid_range(data_empty, FALSE), c(-Inf, Inf))
+})
+
+test_that("dose_grid_range-DataOrdinal works as expected without placebo in grid", {
+ data <- h_get_data_ordinal()
+ data@placebo <- TRUE
+ expect_identical(dose_grid_range(data), c(20, 100))
+ expect_identical(dose_grid_range(data, FALSE), c(10, 100))
+
+ data_1 <- DataOrdinal(doseGrid = c(0.001, 25), placebo = FALSE)
+ expect_identical(dose_grid_range(data_1), c(0.001, 25))
+ expect_identical(dose_grid_range(data_1, FALSE), c(0.001, 25))
+
+ data_2 <- DataOrdinal(doseGrid = 10, placebo = FALSE)
+ expect_identical(dose_grid_range(data_2), c(10, 10))
+ expect_identical(dose_grid_range(data_2, FALSE), c(10, 10))
+
+ data_empty <- DataOrdinal(placebo = FALSE)
+ expect_identical(dose_grid_range(data_empty), c(-Inf, Inf))
+ expect_identical(dose_grid_range(data_empty, FALSE), c(-Inf, Inf))
+})
diff --git a/tests/testthat/test-Data-validity.R b/tests/testthat/test-Data-validity.R
index a80ddbcdb..21fcf5b9c 100644
--- a/tests/testthat/test-Data-validity.R
+++ b/tests/testthat/test-Data-validity.R
@@ -259,6 +259,82 @@ test_that("v_data_da: error for t0 of wrong length, negative values", {
)
})
+# v_data_ordinal ----
+
+test_that("v_data_ordinal passes for valid object", {
+ object <- h_get_data_ordinal()
+ expect_true(v_data_ordinal(object))
+})
+
+test_that("v_data_ordinal correctly detects bad data", {
+ object <- h_get_data_ordinal()
+ object@x[2] <- NA
+ expect_equal(
+ v_data_ordinal(object),
+ c(
+ "Doses vector x must be of type double and length nObs",
+ "Dose values in x must be from doseGrid",
+ "x must be equivalent to doseGrid[xLevel] (up to numerical tolerance)"
+ )
+ )
+
+ object <- h_get_data_ordinal()
+ object@x[2] <- 5
+ expect_equal(
+ v_data_ordinal(object),
+ c(
+ "Dose values in x must be from doseGrid",
+ "x must be equivalent to doseGrid[xLevel] (up to numerical tolerance)"
+ )
+ )
+
+ expect_error(
+ object@yCategories <- c("No tox" = 0, "AE" = 1, "DLT" = 2),
+ "assignment of an object of class \"numeric\" is not valid for @'yCategories' in an object of class \"DataOrdinal\""
+ )
+
+ object <- h_get_data_ordinal()
+ object@y[3] <- 3L
+ expect_equal(
+ v_data_ordinal(object),
+ "DLT vector y must be nObs long and contain integers between 0 and k-1 only, where k is the length of the vector in the yCategories slot" # nolint
+ )
+
+ object <- h_get_data_ordinal()
+ object@yCategories <- c("Good" = 0L, "Bad" = 1L, "Bad" = 2L)
+ expect_equal(
+ v_data_ordinal(object),
+ "yCategory labels must be unique"
+ )
+
+ object <- h_get_data_ordinal()
+ object@x <- c(10, 20, 30, 40, 50, 80, 50, 60, 60, 60)
+ expect_equal(
+ v_data_ordinal(object),
+ c(
+ "x must be equivalent to doseGrid[xLevel] (up to numerical tolerance)",
+ "There must be only one dose level per cohort"
+ )
+ )
+
+ object <- h_get_data_ordinal()
+ object@placebo <- TRUE
+ expect_equal(
+ v_data_ordinal(object),
+ "A cohort with only placebo is not allowed"
+ )
+
+ object <- h_get_data_ordinal()
+ object@placebo <- TRUE
+ object@x <- c(10, 20, 30, 40, 50, 80, 10, 60, 60, 60)
+ object@xLevel <- as.integer(c(1, 2, 3, 4, 5, 8, 1, 6, 6, 6))
+ object@cohort <- as.integer(c(1, 1, 2, 3, 4, 4, 4, 5, 5, 5))
+ expect_equal(
+ v_data_ordinal(object),
+ "There must be only one dose level, other than placebo, per cohort"
+ )
+})
+
# v_data_grouped ----
test_that("v_data_grouped passes for valid object", {
diff --git a/tests/testthat/test-Design-class.R b/tests/testthat/test-Design-class.R
index adf469a4b..ea21ead52 100644
--- a/tests/testthat/test-Design-class.R
+++ b/tests/testthat/test-Design-class.R
@@ -424,3 +424,47 @@ test_that("DADesign user constructor arguments names are as expected", {
ordered = TRUE
)
})
+
+# DesignGrouped ----
+
+test_that(".DesignGrouped works as expected", {
+ result <- .DesignGrouped()
+
+ expect_true(inherits(result, "CrmPackClass"))
+ expect_valid(result, "DesignGrouped")
+})
+
+test_that("DesignGrouped works as expected", {
+ empty_data <- Data(doseGrid = 2:50)
+ model <- .DefaultLogisticLogNormalGrouped()
+ stopping <- h_stopping_target_prob()
+ increments <- h_increments_relative()
+ placebo_cohort_size <- CohortSizeConst(0L)
+ next_best <- h_next_best_ncrm()
+ cohort_size <- CohortSizeRange(intervals = c(0, 30), cohort_size = c(1, 3))
+
+ result <- expect_silent(
+ DesignGrouped(
+ model = model,
+ mono = Design(
+ model,
+ stopping,
+ increments,
+ nextBest = next_best,
+ cohort_size = cohort_size,
+ data = empty_data,
+ startingDose = 3
+ )
+ )
+ )
+
+ expect_valid(result, "DesignGrouped")
+ expect_identical(result@mono, result@combo)
+ expect_true(result@first_cohort_mono_only)
+ expect_true(result@same_dose)
+})
+
+test_that(".DefaultDesignGrouped works as expected", {
+ result <- .DefaultDesignGrouped()
+ expect_valid(result, "DesignGrouped")
+})
diff --git a/tests/testthat/test-Design-methods.R b/tests/testthat/test-Design-methods.R
index a0f8033c4..9f751f3df 100644
--- a/tests/testthat/test-Design-methods.R
+++ b/tests/testthat/test-Design-methods.R
@@ -168,6 +168,151 @@ test_that("stop_reasons can be NA with certain stopping rule settings", {
expect_identical(result, expected)
})
+## DesignGrouped ----
+
+test_that("simulate for DesignGrouped works as expected", {
+ object <- DesignGrouped(
+ model = LogisticLogNormalGrouped(mean = rep(-1, 4), cov = diag(5, 4), ref_dose = 1),
+ mono = Design(
+ model = .LogisticNormal(),
+ nextBest = NextBestNCRM(target = c(0.3, 0.6), overdose = c(0.6, 1), max_overdose_prob = 0.7),
+ stopping = StoppingMinPatients(nPatients = 9),
+ increments = IncrementsDoseLevels(levels = 5),
+ cohort_size = CohortSizeConst(3),
+ data = Data(doseGrid = 1:100),
+ startingDose = 1
+ ),
+ same_dose = TRUE,
+ first_cohort_mono_only = TRUE
+ )
+ my_truth <- function(x) plogis(-4 + 0.2 * log(x / 0.1))
+ my_combo_truth <- function(x) plogis(-4 + 0.5 * log(x / 0.1))
+
+ result <- expect_silent(simulate(
+ object,
+ nsim = 2,
+ seed = 123,
+ truth = my_truth,
+ combo_truth = my_combo_truth,
+ mcmcOptions = h_get_mcmc_options()
+ ))
+
+ expect_list(result)
+ expect_names(names(result), identical.to = c("mono", "combo"))
+ expect_valid(result$mono, "Simulations")
+ expect_valid(result$combo, "Simulations")
+
+ mono_trial <- result$mono@data[[2L]]
+ combo_trial <- result$combo@data[[2L]]
+
+ # First cohort is only mono at the starting dose (lowest in dose grid).
+ expect_true(all(mono_trial@xLevel[1:3] == 1))
+
+ # We have the same dose for subsequent cohorts.
+ expect_true(all(mono_trial@xLevel[4:6] == combo_trial@xLevel[1:3]))
+ expect_true(all(mono_trial@xLevel[7:9] == combo_trial@xLevel[4:6]))
+})
+
+test_that("simulate for DesignGrouped works as expected with different doses, parallel first cohort", {
+ object <- DesignGrouped(
+ model = LogisticLogNormalGrouped(mean = rep(-1, 4), cov = diag(5, 4), ref_dose = 1),
+ mono = Design(
+ model = .LogisticNormal(),
+ nextBest = NextBestNCRM(target = c(0.3, 0.6), overdose = c(0.6, 1), max_overdose_prob = 0.7),
+ stopping = StoppingMinPatients(nPatients = 20),
+ increments = IncrementsDoseLevels(levels = 5),
+ cohort_size = CohortSizeConst(3),
+ data = Data(doseGrid = 1:100),
+ startingDose = 1
+ ),
+ same_dose = FALSE,
+ first_cohort_mono_only = FALSE
+ )
+ my_truth <- function(x) plogis(-4 + 0.2 * log(x / 0.1))
+ my_combo_truth <- function(x) plogis(-4 + 0.9 * log(x / 0.1))
+
+ result <- expect_silent(simulate(
+ object,
+ nsim = 1,
+ seed = 123,
+ truth = my_truth,
+ combo_truth = my_combo_truth,
+ mcmcOptions = h_get_mcmc_options()
+ ))
+
+ expect_list(result)
+ expect_names(names(result), identical.to = c("mono", "combo"))
+ expect_valid(result$mono, "Simulations")
+ expect_valid(result$combo, "Simulations")
+
+ mono_trial <- result$mono@data[[1L]]
+ combo_trial <- result$combo@data[[1L]]
+
+ # First cohort is joint at starting dose.
+ expect_true(all(mono_trial@xLevel[1:3] == combo_trial@xLevel[1:3]))
+
+ # We have different doses in subsequent cohorts.
+ expect_false(all(mono_trial@xLevel[4:20] == combo_trial@xLevel[4:20]))
+})
+
+test_that("simulate for DesignGrouped works when first patient is dosed separately, different combo design", {
+ object <- DesignGrouped(
+ model = LogisticLogNormalGrouped(mean = rep(-1, 4), cov = diag(5, 4), ref_dose = 1),
+ mono = Design(
+ model = .LogisticNormal(),
+ nextBest = NextBestNCRM(target = c(0.3, 0.6), overdose = c(0.6, 1), max_overdose_prob = 0.7),
+ stopping = StoppingMinPatients(nPatients = 10),
+ increments = IncrementsDoseLevels(levels = 3),
+ cohort_size = CohortSizeConst(2),
+ data = Data(doseGrid = 1:100),
+ startingDose = 10
+ ),
+ combo = Design(
+ model = .LogisticNormal(),
+ nextBest = NextBestNCRM(target = c(0.3, 0.6), overdose = c(0.6, 1), max_overdose_prob = 0.7),
+ stopping = StoppingMinPatients(nPatients = 20),
+ increments = IncrementsDoseLevels(levels = 5),
+ cohort_size = CohortSizeConst(3),
+ data = Data(doseGrid = 1:100),
+ startingDose = 1
+ ),
+ same_dose = FALSE,
+ first_cohort_mono_only = FALSE
+ )
+ my_truth <- function(x) plogis(-4 + 0.2 * log(x / 0.1))
+ my_combo_truth <- function(x) plogis(-2 + 0.9 * log(x / 0.1))
+
+ result <- expect_silent(simulate(
+ object,
+ nsim = 1,
+ seed = 123,
+ truth = my_truth,
+ firstSeparate = TRUE,
+ combo_truth = my_combo_truth,
+ mcmcOptions = h_get_mcmc_options()
+ ))
+
+ expect_list(result)
+ expect_names(names(result), identical.to = c("mono", "combo"))
+ expect_valid(result$mono, "Simulations")
+ expect_valid(result$combo, "Simulations")
+
+ mono_trial <- result$mono@data[[1L]]
+ combo_trial <- result$combo@data[[1L]]
+
+ # We expect at least one cohort with just one patient in the combo arm here
+ # because of the high toxicity.
+ expect_true(any(table(combo_trial@cohort) == 1))
+
+ # Check that we had the different cohort sizes between the two arms.
+ expect_true(max(table(mono_trial@cohort)) == 2)
+ expect_true(max(table(combo_trial@cohort)) == 3)
+
+ # Check that we had different starting doses in the two arms.
+ expect_true(mono_trial@x[1] == 10)
+ expect_true(combo_trial@x[1] == 1)
+})
+
# examine ----
## DADesign ----
diff --git a/tests/testthat/test-Design-validity.R b/tests/testthat/test-Design-validity.R
index 5374ad254..651a1e3ba 100644
--- a/tests/testthat/test-Design-validity.R
+++ b/tests/testthat/test-Design-validity.R
@@ -61,3 +61,24 @@ test_that("v_rule_design returns message when startingDose is not on doseGrid",
object@startingDose <- 6.5
expect_equal(v_rule_design(object), err_msg)
})
+
+## v_design_grouped ----
+
+test_that("v_design_grouped passes for valid object", {
+ object <- .DesignGrouped()
+ expect_true(v_design_grouped(object))
+})
+
+test_that("v_design_grouped messages wrong flag slots as expected", {
+ object <- .DesignGrouped()
+
+ object@same_dose <- c(NA, TRUE)
+ object@first_cohort_mono_only <- logical()
+
+ result <- v_design_grouped(object)
+ expected <- c(
+ "first_cohort_mono_only must be a flag",
+ "same_dose must be a flag"
+ )
+ expect_identical(result, expected)
+})
diff --git a/tests/testthat/test-Rules-methods.R b/tests/testthat/test-Rules-methods.R
index 890dd0f06..57d504c4c 100644
--- a/tests/testthat/test-Rules-methods.R
+++ b/tests/testthat/test-Rules-methods.R
@@ -81,13 +81,13 @@ test_that("nextBest-NextBestNCRM returns expected values of the objects (no dose
})
test_that("nextBest-NextBestNCRM can accept additional arguments and pass them to prob inside", {
- my_data <- h_get_data()
- my_model <- h_needs_extra_prob_model()
+ my_data <- h_get_data_grouped()
+ my_model <- .DefaultLogisticLogNormalGrouped()
my_samples <- mcmc(my_data, my_model, h_get_mcmc_options(samples = 10, burnin = 10))
nb_ncrm <- NextBestNCRM(
target = c(0.2, 0.35), overdose = c(0.35, 1), max_overdose_prob = 0.25
)
- result <- nextBest(nb_ncrm, Inf, my_samples, my_model, my_data, extra_argument = "foo")
+ result <- nextBest(nb_ncrm, Inf, my_samples, my_model, my_data, group = "mono")
expect_identical(result$value, NA_real_)
})
@@ -1857,8 +1857,8 @@ test_that("StoppingTargetProb works correctly when above threshold", {
})
test_that("stopTrial-StoppingTargetProb can accept additional arguments and pass them to prob", {
- my_data <- h_get_data()
- my_model <- h_needs_extra_prob_model()
+ my_data <- h_get_data_grouped()
+ my_model <- .DefaultLogisticLogNormalGrouped()
my_samples <- mcmc(my_data, my_model, h_get_mcmc_options(samples = 10, burnin = 10))
stopping <- StoppingTargetProb(target = c(0.1, 0.4), prob = 0.3)
result <- stopTrial(
@@ -1867,7 +1867,7 @@ test_that("stopTrial-StoppingTargetProb can accept additional arguments and pass
samples = my_samples,
model = my_model,
data = my_data,
- extra_argument = "bla"
+ group = "combo"
)
expect_false(result)
})
diff --git a/tests/testthat/test-helpers.R b/tests/testthat/test-helpers.R
index ad687b3ba..90e0be660 100644
--- a/tests/testthat/test-helpers.R
+++ b/tests/testthat/test-helpers.R
@@ -473,7 +473,7 @@ test_that("h_find_interval works as expected for custom replacement", {
test_that("default constructors exist for all subclasses of GeneralModel", {
allModelSubclasses <- names(getClassDef("GeneralModel")@subclasses)
# Exceptions.
- classesNotToTest <- c("DualEndpoint", "NeedsExtraProbModel")
+ classesNotToTest <- "DualEndpoint"
classesToTest <- setdiff(allModelSubclasses, classesNotToTest)
lapply(
classesToTest,
diff --git a/tests/testthat/test-helpers_design.R b/tests/testthat/test-helpers_design.R
new file mode 100644
index 000000000..2c8c18641
--- /dev/null
+++ b/tests/testthat/test-helpers_design.R
@@ -0,0 +1,100 @@
+# set_seed ----
+
+test_that("set_seed returns correct value if seed is a value", {
+ seed <- 1.909
+ seed_int <- 1
+
+ RNGkind("default")
+ rng_state <- set_seed(seed)
+ attr(seed_int, "kind") <- list("Mersenne-Twister", "Inversion", "Rejection")
+ expect_equal(rng_state, seed_int)
+
+ RNGkind("Super-Duper")
+ rng_state <- set_seed(seed)
+ attr(seed_int, "kind") <- list("Super-Duper", "Inversion", "Rejection")
+ expect_equal(rng_state, seed_int)
+
+ RNGkind("default")
+})
+
+test_that("set_seed returns correct value if seed is NULL", {
+ seed <- NULL
+
+ RNGkind("default")
+ rng_state <- set_seed(seed)
+ expect_equal(rng_state, .Random.seed)
+
+ RNGkind("Super-Duper")
+ rng_state <- set_seed(seed)
+ expect_equal(rng_state, .Random.seed)
+
+ RNGkind("default")
+})
+
+# get_result_list ----
+
+test_that("get_result_list returns correct value", {
+ res <- get_result_list(mean, 2, NULL, FALSE, 5)
+ expect_equal(res, list(1, 2))
+
+ res <- get_result_list(length, 2, NULL, FALSE, 5)
+ expect_equal(res, list(1, 1))
+
+ expect_error(get_result_list(length, 2, NULL, 5, 5))
+ expect_error(get_result_list(length, 2, NULL, FALSE, 0))
+})
+
+# h_add_dlts ----
+
+test_that("h_add_dlts works as expected", {
+ data <- h_get_data()
+ cohort_size <- CohortSizeConst(3)
+
+ set.seed(123)
+ result <- expect_silent(h_add_dlts(
+ data = data,
+ dose = data@doseGrid[3],
+ truth = plogis,
+ cohort_size = cohort_size,
+ first_separate = FALSE
+ ))
+ expect_valid(result, "Data")
+ expect_equal(tail(result@x, 3), rep(data@doseGrid[3], 3))
+ expect_true(data@nObs + 3 == result@nObs)
+})
+
+test_that("h_add_dlts works as expected when first separate patient has a DLT", {
+ data <- h_get_data()
+ cohort_size <- CohortSizeConst(3)
+
+ set.seed(123)
+ result <- expect_silent(h_add_dlts(
+ data = data,
+ dose = data@doseGrid[3],
+ truth = function(dose, ...) 1, # Make sure the first patient has a DLT.
+ cohort_size = cohort_size,
+ first_separate = TRUE
+ ))
+ expect_valid(result, "Data")
+ expect_true(tail(result@y, 1) == 1)
+ expect_equal(tail(result@x, 1), data@doseGrid[3])
+ expect_true(data@nObs + 1 == result@nObs)
+})
+
+test_that("h_add_dlts works as expected when first separate patient does not have a DLT", {
+ data <- h_get_data()
+ cohort_size <- CohortSizeConst(3)
+
+ set.seed(123)
+ result <- expect_silent(h_add_dlts(
+ data = data,
+ dose = data@doseGrid[3],
+ truth = function(dose, ...) 0, # Make sure the first patient does not have a DLT.
+ cohort_size = cohort_size,
+ first_separate = TRUE
+ ))
+ expect_valid(result, "Data")
+ expect_equal(tail(result@y, 3), rep(0, 3))
+ expect_equal(tail(result@x, 3), rep(data@doseGrid[3], 3))
+ expect_true(data@nObs + 3 == result@nObs)
+})