diff --git a/.lintr b/.lintr index e5947545e..0a19bc3fd 100644 --- a/.lintr +++ b/.lintr @@ -2,7 +2,7 @@ linters: linters_with_defaults( line_length_linter = line_length_linter(120), cyclocomp_linter = NULL, object_usage_linter = NULL, - trailing_blank_lines_linter = NULL, - trailing_whitespace_linter = NULL, + object_length_linter = NULL, + indentation_linter = NULL, object_name_linter = object_name_linter(c("CamelCase", "camelCase", "snake_case")) ) diff --git a/NAMESPACE b/NAMESPACE index 5c25c8c2b..50bcac1df 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,6 +17,7 @@ export(.DASimulations) export(.Data) export(.DataDA) export(.DataDual) +export(.DataGrouped) export(.DataMixture) export(.DataParts) export(.DefaultCohortSizeConst) @@ -26,6 +27,7 @@ export(.DefaultCohortSizeMin) export(.DefaultCohortSizeParts) export(.DefaultCohortSizeRange) export(.DefaultDALogisticLogNormal) +export(.DefaultDataGrouped) export(.DefaultDualEndpoint) export(.DefaultDualEndpointBeta) export(.DefaultDualEndpointEmax) @@ -181,6 +183,7 @@ export(DASimulations) export(Data) export(DataDA) export(DataDual) +export(DataGrouped) export(DataMixture) export(DataParts) export(Design) @@ -365,6 +368,7 @@ exportClasses(DASimulations) exportClasses(Data) exportClasses(DataDA) exportClasses(DataDual) +exportClasses(DataGrouped) exportClasses(DataMixture) exportClasses(DataParts) exportClasses(Design) diff --git a/NEWS.md b/NEWS.md index 2707c4c73..25af45d59 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,5 @@ # Version 1.0.9000.9133 +* Added new `DataGrouped` class to support simultaneous dose escalation with monotherapy and combination therapy. * 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 00a1cf8d3..3fc92ea50 100644 --- a/R/Data-class.R +++ b/R/Data-class.R @@ -379,3 +379,66 @@ DataDA <- function(u = numeric(), Tmax = as.numeric(Tmax) ) } + +# DataGrouped ---- + +## class ---- + +#' `DataGrouped` +#' +#' @description `r lifecycle::badge("stable")` +#' +#' [`DataGrouped`] is a class for a two groups dose escalation data set, +#' comprised of a monotherapy (`mono`) and a combination therapy (`combo`) +#' arm. It inherits from [`Data`] and it contains the additional group information. +#' +#' @slot group (`factor`)\cr whether `mono` or `combo` was used. +#' +#' @aliases DataGrouped +#' @export +.DataGrouped <- setClass( + Class = "DataGrouped", + slots = c( + group = "factor" + ), + prototype = prototype( + group = factor(levels = c("mono", "combo")) + ), + contains = "Data", + validity = v_data_grouped +) + +## constructor ---- + +#' @rdname DataGrouped-class +#' +#' @param group (`factor` or `character`)\cr whether `mono` or `combo` was used. +#' If `character` then will be coerced to `factor` with the correct levels +#' internally. +#' @param ... parameters passed to [Data()]. +#' +#' @export +#' @example examples/Data-class-DataGrouped.R +#' +DataGrouped <- function(group = character(), + ...) { + d <- Data(...) + if (!is.factor(group)) { + assert_character(group) + assert_subset(group, choices = c("mono", "combo")) + group <- factor(group, levels = c("mono", "combo")) + } + .DataGrouped( + d, + group = group + ) +} + +## default constructor ---- + +#' @rdname DataGrouped-class +#' @note Typically, end users will not use the `.DefaultDataGrouped()` function. +#' @export +.DefaultDataGrouped <- function() { + DataGrouped() +} diff --git a/R/Data-methods.R b/R/Data-methods.R index ec17e4e2c..3fcd3de79 100644 --- a/R/Data-methods.R +++ b/R/Data-methods.R @@ -35,7 +35,7 @@ setMethod( return() } - df <- h_plot_data_df(x, blind) + df <- h_plot_data_df(x, blind, ...) p <- ggplot(df, aes(x = patient, y = dose)) + geom_point(aes(shape = toxicity, colour = toxicity), size = 3) + diff --git a/R/Data-validity.R b/R/Data-validity.R index 00762e7d6..e424a5aee 100644 --- a/R/Data-validity.R +++ b/R/Data-validity.R @@ -180,3 +180,19 @@ v_data_da <- function(object) { ) v$result() } + +#' @describeIn v_data_objects validates that the [`DataGrouped`] object +#' contains valid group information. +v_data_grouped <- function(object) { + v <- Validate() + v$check( + test_factor( + object@group, + levels = c("mono", "combo"), + len = object@nObs, + any.missing = FALSE + ), + "group must be factor with levels mono and combo of length nObs without missings" + ) + v$result() +} diff --git a/R/Rules-methods.R b/R/Rules-methods.R index c3f447fbb..8d5d32127 100644 --- a/R/Rules-methods.R +++ b/R/Rules-methods.R @@ -150,7 +150,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, ...) # Estimates of posterior probabilities that are based on the prob. samples # which are within overdose/target interval. @@ -2229,8 +2229,8 @@ setMethod( is.na(dose), 0, mean( - prob(dose = dose, model, samples) >= stopping@target[1] & - prob(dose = dose, model, samples) <= stopping@target[2] + prob(dose = dose, model, samples, ...) >= stopping@target[1] & + prob(dose = dose, model, samples, ...) <= stopping@target[2] ) ) @@ -2486,8 +2486,10 @@ setMethod( biom_level_samples, 1L, function(x) { rnx <- range(x) - min(which((x >= stopping@target[1] * diff(rnx) + rnx[1]) & - (x <= stopping@target[2] * diff(rnx) + rnx[1] + 1e-10))) + min(which( + (x >= stopping@target[1] * diff(rnx) + rnx[1]) & + (x <= stopping@target[2] * diff(rnx) + rnx[1] + 1e-10) + )) } ) prob_target <- numeric(ncol(biom_level_samples)) @@ -2504,8 +2506,7 @@ setMethod( prob_target <- sapply( seq(1, ncol(biom_level_samples)), function(x) { - sum(biom_level_samples[, x] >= stopping@target[1] & - biom_level_samples[, x] <= stopping@target[2]) / + sum(biom_level_samples[, x] >= stopping@target[1] & biom_level_samples[, x] <= stopping@target[2]) / nrow(biom_level_samples) } ) diff --git a/R/Samples-methods.R b/R/Samples-methods.R index 08a415203..b3d4f6f64 100644 --- a/R/Samples-methods.R +++ b/R/Samples-methods.R @@ -165,7 +165,7 @@ setMethod("get", #' @param object the \code{\linkS4class{Samples}} object #' @param model the \code{\linkS4class{GeneralModel}} object #' @param data the \code{\linkS4class{Data}} object -#' @param \dots unused +#' @param \dots passed down to the [prob()] method. #' @return the data frame with required information (see method details) #' #' @export @@ -232,7 +232,8 @@ setMethod("fit", probSamples[, i] <- prob( dose = points[i], model, - object + object, + ... ) } @@ -532,7 +533,8 @@ setMethod("plot", model = y, data = data, quantiles = c(0.025, 0.975), - middle = mean + middle = mean, + ... ) ## make the plot @@ -1642,10 +1644,10 @@ setMethod("plotGain", data = point_data, inherit.aes = FALSE, aes( - x = X, - y = Y, - shape = as.factor(Shape), - fill = Colour + x = .data$X, + y = .data$Y, + shape = as.factor(.data$Shape), + fill = .data$Colour ), colour = point_data$Colour, size = point_data$Size, diff --git a/R/Simulations-methods.R b/R/Simulations-methods.R index 4ea57484d..71edf2cec 100644 --- a/R/Simulations-methods.R +++ b/R/Simulations-methods.R @@ -181,10 +181,11 @@ setMethod("plot", sapply( simDoses, function(s) { - prop.table(table(factor(s, - levels = - x@data[[1]]@doseGrid - ))) + if (length(s) > 0) { + prop.table(table(factor(s, levels = x@data[[1]]@doseGrid))) + } else { + rep(0, length(x@data[[1]]@doseGrid)) + } } ) diff --git a/R/helpers.R b/R/helpers.R index 16bf7ff1b..2cef53e84 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -1080,3 +1080,39 @@ h_calc_report_label_percentage <- function(stop_report) { stop_pct_to_print <- stop_pct[!is.na(names(stop_pct))] return(stop_pct_to_print) } + +#' Group Together Mono and Combo Data +#' +#' This is only used in the simulation method for `DesignGrouped` to combine +#' the separately generated data sets from mono and combo arms and to fit the +#' combined logistic regression model. +#' Hence the ID and cohort information is not relevant and will be +#' arbitrarily assigned to avoid problems with the [`DataGrouped`] validation. +#' +#' @param mono_data (`Data`)\cr mono data. +#' @param combo_data (`Data`)\cr combo data. +#' +#' @return A [`DataGrouped`] object containing both `mono_data` and `combo_data`, +#' but with arbitrary ID and cohort slots. +#' +#' @keywords internal +h_group_data <- function(mono_data, combo_data) { + assert_class(mono_data, "Data") + assert_class(combo_data, "Data") + + df <- data.frame( + x = c(mono_data@x, combo_data@x), + y = c(mono_data@y, combo_data@y), + group = rep(c("mono", "combo"), c(length(mono_data@x), length(combo_data@x))) + ) + df <- df[order(df$x), ] + + DataGrouped( + x = df$x, + y = df$y, + ID = seq_along(df$x), + cohort = as.integer(factor(df$x)), + doseGrid = sort(unique(c(mono_data@doseGrid, combo_data@doseGrid))), + group = df$group + ) +} diff --git a/_pkgdown.yaml b/_pkgdown.yaml index 146378fac..fdfdab0e1 100644 --- a/_pkgdown.yaml +++ b/_pkgdown.yaml @@ -41,6 +41,7 @@ reference: - DataParts - DataMixture - DataDA + - DataGrouped - McmcOptions - ModelParamsNormal - GeneralModel diff --git a/design/single_combo_grouped.Rmd b/design/single_combo_grouped.Rmd new file mode 100644 index 000000000..1f7075b93 --- /dev/null +++ b/design/single_combo_grouped.Rmd @@ -0,0 +1,893 @@ +--- +title: "Design for grouped mono / combo design" +output: + html_document: + number_sections: true +editor_options: + chunk_output_type: console +--- + +```{r setup, include=FALSE} +library(crmPack) +library(checkmate) +library(ggplot2) + +knitr::opts_chunk$set(echo = TRUE) +``` + +This design introduces prototypes for a design where a monotherapy dose escalation +is directly combined with a combination dose escalation (i.e. the same molecule with +different doses but on top of another fixed dose molecule). + +Note that in this design doc we don't include validation functions yet. + +# The data: `DataGrouped` + +The idea is that we start from `Data`. Even though we need the 2 parts feature +due to the safety run-in requirement, we can handle that separately in the +`DesignGrouped`. We add a slot `group` which is a factor +with 2 levels of the same length, similar as we add the biomarker `w` in the +class `DataDual`. + +The helper function `groupData` is only used in the simulation method to combine +methods. Hence the ID and cohort information is not relevant and will be +arbitrarily assigned to avoid problems with the `Data` validation. + +## Definition + +```{r DataGrouped-class} +.DataGrouped <- setClass( + Class = "DataGrouped", + slots = c( + group = "factor" + ), + prototype = prototype( + group = factor(levels = c("mono", "combo")) + ), + contains = "Data" +) + +DataGrouped <- function(group, + ...) { + d <- Data(...) + .DataGrouped( + d, + group = group + ) +} + +groupData <- function(mono_data, combo_data) { + assert_class(mono_data, "Data") + assert_class(combo_data, "Data") + + # We just combine most of the slots logically, but assign ID and cohort + # arbitrarily to avoid Data object validation issues. + df <- data.frame( + x = c(mono_data@x, combo_data@x), + y = c(mono_data@y, combo_data@y), + group = factor( + rep(c("mono", "combo"), c(length(mono_data@x), length(combo_data@x))), + levels = c("mono", "combo") + ) + ) + + df <- df[order(df$x), ] + + DataGrouped( + x = df$x, + y = df$y, + ID = seq_along(df$x), + cohort = as.integer(factor(df$x)), + doseGrid = sort(unique(c(mono_data@doseGrid, combo_data@doseGrid))), + # Here comes the group information. + group = df$group + ) +} +``` + +## Methods + +Note that for the `plot` method to be able to use the parent method for starting +the plot, we need to make sure additional arguments are passed inside to the +`h_plot_data_df()` function initializing the `ggplot2` data set. + +```{r DataGrouped-methods} +setMethod( + f = "update", + signature = signature(object = "DataGrouped"), + definition = function(object, group, ..., check = TRUE) { + assert_character(group) + assert_flag(check) + + # Update slots corresponding to `Data` class. + object <- callNextMethod(object = object, ..., check = FALSE) + + # Update the group information. + group <- factor(group, levels = levels(object@group)) + object@group <- c(object@group, group) + + if (check) { + validObject(object) + } + + object + } +) + +setMethod( + f = "plot", + signature = signature(x = "DataGrouped", y = "missing"), + definition = function(x, y, blind = FALSE, ...) { + assert_flag(blind) + + # Call the superclass method, to get the initial plot layout. + # Make sure `group` is available. + p <- callNextMethod(x, blind = blind, legend = FALSE, group = x@group, ...) + + # Now add the faceting by group. + p + facet_wrap(vars(group), nrow = 2) + } +) +``` + +## Example + +```{r DataGrouped-example} +my_data <- DataGrouped( + x = c(0.1, 0.1, 0.5, 0.5, 1.5, 1.5), + y = c(0, 0, 0, 0, 1, 0), + group = factor(rep(c("mono", "combo"), 3), levels = c("mono", "combo")), + ID = 1:6, + cohort = rep(1:3, each = 2), + doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)) +) +my_ref_dose <- 0.1 # Lowest dose in dose grid, see comment below. + +plot(my_data) +my_data_2 <- update(my_data, x = 3, y = c(0, 0), group = c("mono", "combo")) +plot(my_data_2) + +my_mono_data <- Data( + x = c(0.1, 0.1, 0.5, 0.5, 1.5, 1.5), + y = c(0, 0, 0, 0, 1, 0), + ID = 1:6, + cohort = rep(1:3, each = 2), + doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)) +) +my_combo_data <- Data( + x = c(0.1, 0.1, 0.5, 0.5, 1.5, 1.5), + y = c(0, 0, 0, 0, 1, 0), + ID = 1:6, + cohort = rep(1:3, each = 2), + doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)) +) +my_grouped_data <- groupData(my_mono_data, my_combo_data) +``` + +# The model: `LogisticLogNormalGrouped` + +We can inherit from `ModelLogNormal`. Compared to `LogisticLogNormal` etc. +we have two additional parameters in `theta` which are then also exponentiated to +obtain the corresponding `alpha` parameters. + +We note that here `refDose` should be chosen carefully. +- In a scenario where the toxicity can reasonably be assumed to be +higher for the combination than for the mono agent: Then the `refDose` should be +(below or) equal to the lowest dose, such that the term `log(dose / ref_dose)` +is never negative and hence the probability of DLT will be higher for combo than +for mono agent. +- In a scenario where it is the other way around, e.g. the combination with +a concomitant medication is compared with the mono agent, then `refDose` +should be (above or) equal to the highest dose. +- Otherwise it can be chosen in between. + +Also variants of the proposed model might not restrict `delta0` and `delta1` to be +positive giving more flexibility of the model and then the `refDose` choice is less +critical. + +## Definition + +Note that this can easily be extended later (either with a flag or with another +class) to not use log dose but dose instead (divided by reference dose). + +```{r LogisticLogNormalGrouped-class} +.LogisticLogNormalGrouped <- setClass( + Class = "LogisticLogNormalGrouped", + contains = "ModelLogNormal" +) + +LogisticLogNormalGrouped <- function(mean, cov, ref_dose = 1) { + params <- ModelParamsNormal(mean, cov) + .LogisticLogNormalGrouped( + params = params, + ref_dose = crmPack:::positive_number(ref_dose), + priormodel = function() { + theta ~ dmnorm(mean, prec) + alpha0 <- theta[1] + delta0 <- exp(theta[2]) + alpha1 <- exp(theta[3]) + delta1 <- exp(theta[4]) + }, + datamodel = function() { + for (i in 1:nObs) { + logit(p[i]) <- (alpha0 + is_combo[i] * delta0) + + (alpha1 + is_combo[i] * delta1) * log(x[i] / ref_dose) + y[i] ~ dbern(p[i]) + } + }, + modelspecs = function(group, from_prior) { + ms <- list( + mean = params@mean, + prec = params@prec + ) + if (!from_prior) { + ms$ref_dose <- ref_dose + ms$is_combo <- as.integer(group == "combo") + } + ms + }, + init = function() { + list(theta = c(0, 1, 1, 1)) + }, + datanames = c("nObs", "y", "x"), + sample = c("alpha0", "delta0", "alpha1", "delta1") + ) +} +``` + +## Methods + +```{r LogisticLogNormalGrouped-methods} +setMethod( + f = "prob", + signature = signature( + dose = "numeric", + model = "LogisticLogNormalGrouped", + samples = "Samples" + ), + definition = function(dose, model, samples, group) { + assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L) + assert_subset(c("alpha0", "delta0", "alpha1", "delta1"), names(samples)) + assert_length(dose, len = size(samples)) + assert_factor(group, len = length(dose), levels = c("mono", "combo")) + + alpha0 <- samples@data$alpha0 + delta0 <- samples@data$delta0 + alpha1 <- samples@data$alpha1 + delta1 <- samples@data$delta1 + ref_dose <- as.numeric(model@ref_dose) + is_combo <- as.integer(group == "combo") + plogis((alpha0 + is_combo * delta0) + (alpha1 + is_combo * delta1) * log(dose / ref_dose)) + } +) + +setMethod( + f = "dose", + signature = signature( + x = "numeric", + model = "LogisticLogNormalGrouped", + samples = "Samples" + ), + definition = function(x, model, samples, group) { + assert_probabilities(x) + assert_subset(c("alpha0", "delta0", "alpha1", "delta1"), names(samples)) + assert_length(x, len = size(samples)) + assert_factor(group, len = length(x), levels = c("mono", "combo")) + + alpha0 <- samples@data$alpha0 + delta0 <- samples@data$delta0 + alpha1 <- samples@data$alpha1 + delta1 <- samples@data$delta1 + ref_dose <- as.numeric(model@ref_dose) + is_combo <- as.integer(group == "combo") + exp((logit(x) - (alpha0 + is_combo * delta0)) / (alpha1 + is_combo * delta1)) * ref_dose + } +) +``` + +Note that for the `fit` method we need to make sure that the `...` are passed down to `prob`, +such that we can pass down the `group` argument. + +We have added a corresponding unit test already in this PR. + +Note that in production we will need to modify the `doseFunction` and `probFunction` method +definitions accordingly to allow for the passing of the `group` (or other) arguments +as well. + +## Example + +```{r LogisticLogNormalGrouped-example} +my_model <- LogisticLogNormalGrouped( + mean = rep(0, 4), + cov = diag(rep(1, 4)), + ref_dose = my_ref_dose +) + +my_options <- McmcOptions() +my_samples <- mcmc(my_data, my_model, my_options) +str(my_samples) + +mean(my_samples@data$delta0) +mean(my_samples@data$delta1) +mean(prob(dose = 5, my_model, my_samples, factor("mono", levels = c("mono", "combo")))) +mean(prob(dose = 5, my_model, my_samples, factor("combo", levels = c("mono", "combo")))) + +one_sample <- Samples( + data = list(alpha0 = -0.5, delta0 = 0.1, alpha1 = 0.3, delta1 = 0.5), + options = McmcOptions(samples = 1L) +) + +td50_mono <- dose(x = 0.5, my_model, one_sample, factor("mono", levels = c("mono", "combo"))) +td50_combo <- dose(x = 0.5, my_model, one_sample, factor("combo", levels = c("mono", "combo"))) + +prob(dose = td50_mono, my_model, one_sample, factor("mono", levels = c("mono", "combo"))) +prob(dose = td50_combo, my_model, one_sample, factor("combo", levels = c("mono", "combo"))) + +fit_mono <- fit(one_sample, my_model, my_data, group = factor("mono", levels = c("mono", "combo"))) +fit_combo <- fit(one_sample, my_model, my_data, group = factor("combo", levels = c("mono", "combo"))) +matplot(x = fit_mono$dose, y = cbind(fit_mono$middle, fit_combo$middle), type = "l") +``` + +## Prior elicitation + +As usual we can sample from the prior and look at the fit results. +For this to work well we also need to pass additional arguments in the plot method. + +We have added a unit test for the plot method of the Samples class already as well. + +```{r initial-pars} +# Need to choose the prior parameters here. +my_model <- LogisticLogNormalGrouped( + mean = rep(0, 4), + cov = diag(rep(1, 4)), + ref_dose = my_ref_dose +) + +# Create empty data. +my_empty_data <- DataGrouped( + doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)), + group = factor(levels = c("mono", "combo")) +) + +# Sample from the prior. +my_options <- McmcOptions() +my_prior_samples <- mcmc(my_empty_data, my_model, my_options) +str(my_prior_samples) + +# Look at fit results. +plot( + my_prior_samples, my_model, my_empty_data, + group = factor("mono", levels = c("mono", "combo")) +) +plot( + my_prior_samples, my_model, my_empty_data, + group = factor("combo", levels = c("mono", "combo")) +) +``` + +So we can see here that the design is very informative, because the credible +intervals are pretty narrow. We also expect a high toxicity already at low dose +levels. +Let's therefore modify the parameters. + +```{r prior-elicitation} +# Need to choose the prior parameters here. +my_model <- LogisticLogNormalGrouped( + mean = c(-4, -4, -4, -4), + cov = diag(rep(6, 4)), + ref_dose = my_ref_dose +) +my_prior_samples <- mcmc(my_empty_data, my_model, my_options) +plot( + my_prior_samples, my_model, my_empty_data, + group = factor("mono", levels = c("mono", "combo")) +) +plot( + my_prior_samples, my_model, my_empty_data, + group = factor("combo", levels = c("mono", "combo")) +) +``` + +This looks more reasonable. + +# The design: `DesignGrouped` + +It seems easiest to combine two `Design` objects here in one - so we have one +for the mono agent and one for the combo group, because then we get all the rules +at once. Note that his implicitly +handles the randomization ratio as the ratio between the cohort sizes, but +allows for much more flexibility. If missing in the user constructor, we assume +that the same rule as for the mono agent is followed. Note that for the part 1 +handling with fewer patients per cohort the design class does not need to know +about it, because the data and the size rules handle this already. + +Here we add the flag `first_cohort_mono_only`. When turned on, this means +that we first test one mono agent cohort. Once that DLT data has been collected, we proceed +from the second cohort onwards with concurrent mono and combo cohorts. + +We also add a flag `same_dose` to specify whether the lower dose of the separately determined mono and combo doses should be used as the next dose for both mono and combo. This might or might not be desired in the given situation. + +Note that we deliberately ignore information in `Design`, including the model +and the placebo cohort size information in there. This is not super clean, +but ok at least for this first prototype. + +## Definition + +```{r DesignGrouped-class} +.DesignGrouped <- setClass( + Class = "DesignGrouped", + slots = c( + model = "LogisticLogNormalGrouped", + mono = "Design", + combo = "Design", + first_cohort_mono_only = "logical", + same_dose = "logical" + ) +) + +DesignGrouped <- function(model, + mono, + combo, + first_cohort_mono_only, + same_dose, + ...) { + if (missing(combo)) combo <- mono + + .DesignGrouped( + model = model, + mono = mono, + combo = combo, + first_cohort_mono_only = first_cohort_mono_only, + same_dose = same_dose + ) +} +``` + +## Methods + +Let's for now just look at the simulation method. In production we also +need the `examine` method though, but it is going to follow a similar logic. + +For simplicity we don't support the `firstSeparate` argument here for now. +Since we have two groups now, we also have two true dose-toxicity relationships +now. We therefore add the `combo_truth` argument. + +Note that in order for the `nextBest` method to work out of the box, we just need +to pass again the `...` arguments down to e.g. the `prob` method used inside. +We do this in this PR already for the `NextBestNCRM` method as illustration. + +The same applies for the `stopTrial` methods. We here do it for `StoppingTargetProb` +as illustration. + +For both methods updates we have unit tests in this PR already. + +```{r DesignGrouped-methods} +setMethod("simulate", + signature = + signature( + object = "DesignGrouped", + nsim = "ANY", + seed = "ANY" + ), + def = + function(object, + nsim = 1L, + seed = NULL, + truth, + combo_truth, + args = NULL, + mcmcOptions = McmcOptions(), + parallel = FALSE, + nCores = min(parallelly::availableCores(), 5), + ...) { + nsim <- crmPack:::safeInteger(nsim) + + ## checks and extracts + stopifnot( + is.function(truth), + is.function(combo_truth), + crmPack:::is.scalar(nsim), + nsim > 0, + crmPack:::is.bool(parallel), + crmPack:::is.scalar(nCores), + nCores > 0 + ) + + args <- as.data.frame(args) + nArgs <- max(nrow(args), 1L) + + ## seed handling + RNGstate <- setSeed(seed) + + ## from this, + ## generate the individual seeds for the simulation runs + simSeeds <- sample.int(n = 2147483647, size = nsim) + + ## the function to produce the run a mono simulation + ## with index "iterSim" + runSim <- function(iterSim) { + ## set the seed for this run + set.seed(simSeeds[iterSim]) + + ## what is now the argument for the truth? + ## (appropriately recycled) + thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE] + + ## so this truth for mono agent is... + this_mono_truth <- function(dose) { + do.call(truth, c(dose, thisArgs)) + } + + ## and for combo similarly: + this_combo_truth <- function(dose) { + do.call(combo_truth, c(dose, thisArgs)) + } + + ## start the simulated data with the provided one + this_mono_data <- object@mono@data + this_combo_data <- object@combo@data + + ## shall we stop the trial? separately for mono and combo. + ## First, we want to continue with the starting dose. + ## This variable is updated after each cohort in the loop. + stop_mono <- stop_combo <- FALSE + + ## are we in the first cohort? This is to support the staggering feature + first_cohort <- TRUE + + ## what are the next doses to be used? + ## initialize with starting doses + if (object@mono@startingDose < object@combo@startingDose) { + warning("combo starting dose usually not higher than mono starting dose") + } + if (object@same_dose) { + this_mono_dose <- this_combo_dose <- min( + object@mono@startingDose, + object@combo@startingDose + ) + } else { + this_mono_dose <- object@mono@startingDose + this_combo_dose <- object@combo@startingDose + } + + ## inside this loop we simulate the whole trial, until stopping + while (!(stop_mono && stop_combo)) { + if (!stop_mono) { + ## what is the probability for tox. at this dose? + this_mono_prob <- this_mono_truth(this_mono_dose) + + ## what is the mono cohort size at this dose? + this_mono_size <- size( + object@mono@cohort_size, + dose = this_mono_dose, + data = this_mono_data + ) + ## we can dose the mono patients + this_mono_dlts <- rbinom( + n = this_mono_size, + size = 1, + prob = this_mono_prob + ) + ## update the mono data with this cohort + this_mono_data <- update( + object = this_mono_data, + x = this_mono_dose, + y = this_mono_dlts + ) + } + + ## Check if we also dose combo patients now + if (!stop_combo && (!first_cohort || !object@first_cohort_mono_only)) { + this_combo_prob <- this_combo_truth(this_combo_dose) + + ## what is the combo cohort size at this dose? + this_combo_size <- size( + object@combo@cohort_size, + dose = this_combo_dose, + data = this_combo_data + ) + ## we can dose the combo patients + this_combo_dlts <- rbinom( + n = this_combo_size, + size = 1, + prob = this_combo_prob + ) + ## update the data with this cohort + this_combo_data <- update( + object = this_combo_data, + x = this_combo_dose, + y = this_combo_dlts + ) + } + + ## update first cohort flag + if (first_cohort) { + first_cohort <- FALSE + } + + ## join the data together + grouped_data <- groupData( + this_mono_data, + this_combo_data + ) + + ## generate samples from the joint model + thisSamples <- mcmc( + data = grouped_data, + model = object@model, + options = mcmcOptions + ) + + if (!stop_mono) { + mono_dose_limit <- maxDose( + object@mono@increments, + data = this_mono_data + ) + + ## => what is the next best dose for mono? + this_mono_dose <- nextBest( + object@mono@nextBest, + doselimit = mono_dose_limit, + samples = thisSamples, + model = object@model, + data = grouped_data, + group = factor("mono", levels = c("mono", "combo")) + )$value + + stop_mono <- stopTrial( + object@mono@stopping, + dose = this_mono_dose, + samples = thisSamples, + model = object@model, + data = this_mono_data, + group = factor("mono", levels = c("mono", "combo")) + ) + + stop_mono_results <- crmPack:::h_unpack_stopit(stop_mono) + } + + if (!stop_combo) { + combo_dose_limit <- if (is.na(this_mono_dose)) { + 0 + } else { + combo_max_dose <- maxDose( + object@combo@increments, + data = this_combo_data + ) + min( + combo_max_dose, + this_mono_dose, + na.rm = TRUE + ) + } + + this_combo_dose <- nextBest( + object@combo@nextBest, + doselimit = combo_dose_limit, + samples = thisSamples, + model = object@model, + data = grouped_data, + group = factor("combo", levels = c("mono", "combo")) + )$value + + stop_combo <- stopTrial( + object@combo@stopping, + dose = this_combo_dose, + samples = thisSamples, + model = object@model, + data = this_combo_data, + group = factor("combo", levels = c("mono", "combo")) + ) + + stop_combo_results <- crmPack:::h_unpack_stopit(stop_combo) + + if (object@same_dose) { + this_mono_dose <- this_combo_dose <- min( + this_mono_dose, + this_combo_dose + ) + } + } + } + + ## get the fit, separately for mono and for combo + fit_mono <- fit( + object = thisSamples, + model = object@model, + data = grouped_data, + group = factor("mono", levels = c("mono", "combo")) + ) + fit_combo <- fit( + object = thisSamples, + model = object@model, + data = grouped_data, + group = factor("combo", levels = c("mono", "combo")) + ) + + ## return the results + thisResult <- list( + mono = list( + data = this_mono_data, + dose = this_mono_dose, + fit = subset(fit_mono, select = -dose), + stop = attr(stop_mono, "message"), + report_results = stop_mono_results + ), + combo = list( + data = this_combo_data, + dose = this_combo_dose, + fit = subset(fit_combo, select = -dose), + stop = attr(stop_combo, "message"), + report_results = stop_combo_results + ) + ) + + return(thisResult) + } + + resultList <- crmPack:::getResultList( + fun = runSim, + nsim = nsim, + vars = + c( + "simSeeds", + "args", + "nArgs", + "truth", + "object", + "mcmcOptions" + ), + parallel = if (parallel) nCores else NULL + ) + + ## now we have a list with each element containing mono and combo, + ## but we want it now the other way around, i.e. a list with 2 elements + ## mono and combo and the iterations inside. + resultList <- list( + mono = lapply(resultList, "[[", "mono"), + combo = lapply(resultList, "[[", "combo") + ) + + ## put everything in a list with both mono and combo Simulations: + lapply(resultList, 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, "[[", "report_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 = RNGstate + ) + }) + } +) +``` + +## Example + +```{r DesignGrouped-example} +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_design <- DesignGrouped( + model = my_model, + mono = Design( + model = .ModelLogNormal(), # is not used + stopping = my_stopping, + increments = my_increments, + nextBest = my_next_best, + cohort_size = my_cohort_size, + data = empty_data, + startingDose = 0.1 + ), + combo = Design( + model = .ModelLogNormal(), # is not used + 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 = FALSE +) + +my_model@datamodel +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)) + +my_sims <- simulate( + my_design, + nsim = 20, + seed = 123, + truth = my_truth, + combo_truth = my_combo_truth +) +``` + +Let's have a look at the simulation results. + +```{r DesignGrouped-sim-results} +plot(my_sims$mono) +plot(my_sims$combo) + +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) +``` + +So this seems to work nicely because we are now back to "normal" simulation +results. + +We only needed to add a condition inside the Simulations plot method to make +sure that if there is no patients dosed at all (which can happen here for +combo when mono is too toxic already) that it still works. + +```{r examine-sims} +cbind( + mono = my_sims$mono@doses, + combo = my_sims$combo@doses +) + +plot(my_sims$mono@data[[1]]) +plot(my_sims$combo@data[[1]]) +``` + +So here we have allowed the mono and combo doses to be different for each cohort. +And we can now also try out forcing the same dose for the mono and combo cohorts: + +```{r try-same-dose} +my_design2 <- my_design +my_design@same_dose <- TRUE + +my_sims_same_dose <- simulate( + my_design2, + nsim = 1, + seed = 123, + truth = my_truth, + combo_truth = my_combo_truth +) + +plot(my_sims_same_dose$mono) +plot(my_sims_same_dose$combo) + +plot(my_sims_same_dose$mono@data[[1]]) +plot(my_sims_same_dose$combo@data[[1]]) +``` + +This looks ok. Note that when we have staggered the first cohort as here and limit +the sample size for mono and combo at the same maximum then we might stop mono +earlier than combo. diff --git a/examples/Data-class-DataGrouped.R b/examples/Data-class-DataGrouped.R new file mode 100644 index 000000000..27a287332 --- /dev/null +++ b/examples/Data-class-DataGrouped.R @@ -0,0 +1,12 @@ +my_data <- DataGrouped( + x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10), + y = c(0, 0, 1, 1, 0, 0, 1, 0), + doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)), + group = c("mono", "mono", "mono", "mono", "mono", "mono", "combo", "combo") +) + +# Set up an empty data set. +empty_data <- DataGrouped( + doseGrid = c(0.1, 0.5, 1, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)) +) +empty_data diff --git a/inst/WORDLIST b/inst/WORDLIST index e2cf49995..b9e74ed2b 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -227,6 +227,7 @@ modelled modelling ModelPseudo ModelTox +monotherapy MTD multisessions multithreaded diff --git a/man/DataGrouped-class.Rd b/man/DataGrouped-class.Rd new file mode 100644 index 000000000..8882e962b --- /dev/null +++ b/man/DataGrouped-class.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Data-class.R +\docType{class} +\name{DataGrouped-class} +\alias{DataGrouped-class} +\alias{.DataGrouped} +\alias{DataGrouped} +\alias{.DefaultDataGrouped} +\title{\code{DataGrouped}} +\usage{ +DataGrouped(group = character(), ...) + +.DefaultDataGrouped() +} +\arguments{ +\item{group}{(\code{factor} or \code{character})\cr whether \code{mono} or \code{combo} was used. +If \code{character} then will be coerced to \code{factor} with the correct levels +internally.} + +\item{...}{parameters passed to \code{\link[=Data]{Data()}}.} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +\code{\link{DataGrouped}} is a class for a two groups dose escalation data set, +comprised of a monotherapy (\code{mono}) and a combination therapy (\code{combo}) +arm. It inherits from \code{\link{Data}} and it contains the additional group information. +} +\section{Slots}{ + +\describe{ +\item{\code{group}}{(\code{factor})\cr whether \code{mono} or \code{combo} was used.} +}} + +\note{ +Typically, end users will not use the \code{.DefaultDataGrouped()} function. +} +\examples{ +my_data <- DataGrouped( + x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10), + y = c(0, 0, 1, 1, 0, 0, 1, 0), + doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)), + group = c("mono", "mono", "mono", "mono", "mono", "mono", "combo", "combo") +) + +# Set up an empty data set. +empty_data <- DataGrouped( + doseGrid = c(0.1, 0.5, 1, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)) +) +empty_data +} diff --git a/man/fit.Rd b/man/fit.Rd index cd9b49fe0..c7f8e30b1 100644 --- a/man/fit.Rd +++ b/man/fit.Rd @@ -60,7 +60,7 @@ fit(object, model, data, ...) \item{data}{the \code{\linkS4class{Data}} object} -\item{\dots}{unused} +\item{\dots}{passed down to the \code{\link[=prob]{prob()}} method.} \item{points}{at which dose levels is the fit requested? default is the dose grid} diff --git a/man/h_group_data.Rd b/man/h_group_data.Rd new file mode 100644 index 000000000..f98429a39 --- /dev/null +++ b/man/h_group_data.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helpers.R +\name{h_group_data} +\alias{h_group_data} +\title{Group Together Mono and Combo Data} +\usage{ +h_group_data(mono_data, combo_data) +} +\arguments{ +\item{mono_data}{(\code{Data})\cr mono data.} + +\item{combo_data}{(\code{Data})\cr combo data.} +} +\value{ +A \code{\link{DataGrouped}} object containing both \code{mono_data} and \code{combo_data}, +but with arbitrary ID and cohort slots. +} +\description{ +This is only used in the simulation method for \code{DesignGrouped} to combine +the separately generated data sets from mono and combo arms and to fit the +combined logistic regression model. +Hence the ID and cohort information is not relevant and will be +arbitrarily assigned to avoid problems with the \code{\link{DataGrouped}} validation. +} +\keyword{internal} diff --git a/man/v_data_objects.Rd b/man/v_data_objects.Rd index c4f044621..f3958cbd1 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_grouped} \title{Internal Helper Functions for Validation of \code{\link{GeneralData}} Objects} \usage{ v_general_data(object) @@ -24,6 +25,8 @@ v_data_parts(object) v_data_mixture(object) v_data_da(object) + +v_data_grouped(object) } \arguments{ \item{object}{(\code{GeneralData})\cr object to validate.} @@ -68,4 +71,7 @@ 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_grouped()}: validates that the \code{\link{DataGrouped}} object +contains valid group information. + }} diff --git a/tests/testthat/helper-data.R b/tests/testthat/helper-data.R index 3fefc2c32..a9ce8a03f 100644 --- a/tests/testthat/helper-data.R +++ b/tests/testthat/helper-data.R @@ -1,3 +1,5 @@ +# Data ---- + h_get_data <- function(empty = FALSE, placebo = TRUE) { dose_grid <- seq(25, 300, 25) if (placebo) { @@ -49,6 +51,8 @@ h_get_data_2 <- function() { ) } +# DataDual ---- + h_get_data_dual <- function(empty = FALSE, placebo = TRUE) { d <- h_get_data(empty, placebo) if (empty) { @@ -61,6 +65,8 @@ h_get_data_dual <- function(empty = FALSE, placebo = TRUE) { } } +# DataParts ---- + h_get_data_parts <- function(empty = FALSE, placebo = TRUE) { d <- h_get_data(empty, placebo) if (empty) { @@ -89,6 +95,8 @@ h_get_data_parts_1 <- function(empty = FALSE, placebo = TRUE) { } } +# DataMixture ---- + h_get_data_mixture <- function(empty = FALSE, placebo = TRUE) { d <- h_get_data(empty, placebo) if (empty) { @@ -103,6 +111,8 @@ h_get_data_mixture <- function(empty = FALSE, placebo = TRUE) { } } +# DataDA ---- + h_get_data_da <- function(empty = FALSE, placebo = TRUE) { d <- h_get_data(empty, placebo) if (empty) { @@ -151,3 +161,23 @@ h_get_data_sr_2 <- function() { doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)) ) } + +# DataGrouped ---- + +h_get_data_grouped <- function(empty = FALSE, placebo = TRUE) { + d <- h_get_data(empty, placebo) + if (empty) { + .DataGrouped(d) + } else { + .DataGrouped( + d, + group = factor( + c( + "mono", "mono", "combo", "combo", "mono", "mono", "combo", + "combo", "mono", "mono", "combo", "combo" + ), + levels = c("mono", "combo") + ) + ) + } +} diff --git a/tests/testthat/helper-model.R b/tests/testthat/helper-model.R index b56e23665..e1725a900 100644 --- a/tests/testthat/helper-model.R +++ b/tests/testthat/helper-model.R @@ -386,3 +386,22 @@ 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 b504999a0..c8c83bc42 100644 --- a/tests/testthat/test-Data-class.R +++ b/tests/testthat/test-Data-class.R @@ -185,3 +185,36 @@ test_that("DataDA object can be created with custom values", { ) expect_valid(result, "DataDA") }) + +# DataGrouped-class ---- + +test_that(".DataGrouped works as expected", { + result <- expect_silent(.DataGrouped()) + expect_valid(result, "DataGrouped") +}) + +# DataGrouped-constructor ---- + +test_that("DataGrouped object can be created with user constructor DataGrouped", { + result <- expect_silent(DataGrouped()) + expect_valid(result, "DataGrouped") +}) + +test_that("DataGrouped object can be created with custom values", { + result <- expect_silent( + DataGrouped( + group = c("mono", "combo", "mono"), + 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)) + ) + ) + expect_valid(result, "DataGrouped") +}) + +test_that("DataGrouped default constructor works as expected", { + result <- expect_silent(.DefaultDataGrouped()) + expect_valid(result, "DataGrouped") +}) diff --git a/tests/testthat/test-Data-validity.R b/tests/testthat/test-Data-validity.R index b91485277..a80ddbcdb 100644 --- a/tests/testthat/test-Data-validity.R +++ b/tests/testthat/test-Data-validity.R @@ -258,3 +258,32 @@ test_that("v_data_da: error for t0 of wrong length, negative values", { "t0 must be of type double, nObs length, sorted non-negative" ) }) + +# v_data_grouped ---- + +test_that("v_data_grouped passes for valid object", { + object <- h_get_data_grouped() + expect_true(v_data_grouped(object)) +}) + +test_that("v_data_grouped fails for wrong length", { + object <- h_get_data_grouped() + + object@group <- object@group[1:5] + + expect_identical( + v_data_grouped(object), + "group must be factor with levels mono and combo of length nObs without missings" + ) +}) + +test_that("v_data_grouped fails for wrong factor levels", { + object <- h_get_data_grouped() + + object@group <- factor(object@group, levels = c("mono", "combo", "foo")) + + expect_identical( + v_data_grouped(object), + "group must be factor with levels mono and combo of length nObs without missings" + ) +}) diff --git a/tests/testthat/test-Rules-methods.R b/tests/testthat/test-Rules-methods.R index 9eac4f113..890dd0f06 100644 --- a/tests/testthat/test-Rules-methods.R +++ b/tests/testthat/test-Rules-methods.R @@ -80,6 +80,17 @@ test_that("nextBest-NextBestNCRM returns expected values of the objects (no dose vdiffr::expect_doppelganger("Plot of nextBest-NextBestNCRM without doselimit", result$plot) }) +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_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") + expect_identical(result$value, NA_real_) +}) + ## NextBestNCRM-DataParts ---- test_that("nextBest-NextBestNCRM-DataParts returns expected values of the objects", { @@ -1845,6 +1856,22 @@ test_that("StoppingTargetProb works correctly when above threshold", { expect_identical(result, expected) }) +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_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( + stopping = stopping, + dose = 100, + samples = my_samples, + model = my_model, + data = my_data, + extra_argument = "bla" + ) + expect_false(result) +}) + ## StoppingMTDdistribution ---- test_that("StoppingMTDdistribution can handle when dose is NA", { diff --git a/tests/testthat/test-Samples-methods.R b/tests/testthat/test-Samples-methods.R index e6a82254a..e78424553 100644 --- a/tests/testthat/test-Samples-methods.R +++ b/tests/testthat/test-Samples-methods.R @@ -205,6 +205,18 @@ test_that("fit-Samples works correctly for tox-only models", { checkIt(seed = 789, lowerQuantile = 0.25, upperQuantile = 0.75) }) +test_that("fit-Samples forwards additional arguments to prob inside", { + mcmcOptions <- McmcOptions(samples = 3) + samples <- Samples(data = list(alpha0 = 1:3, alpha1 = 4:6), options = mcmcOptions) + model <- h_needs_extra_prob_model() + emptyData <- Data(doseGrid = seq(10, 80, 10)) + + result <- fit(samples, model, emptyData, extra_argument = "yes") + expect_data_frame(result) + expect_equal(nrow(result), length(emptyData@doseGrid)) + expect_named(result, c("dose", "middle", "lower", "upper")) +}) + ## Samples-DataModel ---- test_that("fit-Samples works correctly for dual models", { @@ -367,6 +379,16 @@ test_that("plot-Samples works correctly", { vdiffr::expect_doppelganger("plot-Samples_showLegend-FALSE", actual1) }) +test_that("plot-Samples forwards additional arguments to prob inside", { + mcmcOptions <- McmcOptions(samples = 3) + samples <- Samples(data = list(alpha0 = 1:3, alpha1 = 4:6), options = mcmcOptions) + model <- h_needs_extra_prob_model() + emptyData <- Data(doseGrid = seq(10, 80, 10)) + + result <- plot(samples, model, emptyData, extra_argument = "yes") + expect_list(result) +}) + test_that("plot-Samples-DualEndpoint fails gracefully with bad input", { data <- DataDual( x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10, 20, 20, 20, 40, 40, 40, 50, 50, 50), diff --git a/tests/testthat/test-helpers.R b/tests/testthat/test-helpers.R index c4f2d5428..ad687b3ba 100644 --- a/tests/testthat/test-helpers.R +++ b/tests/testthat/test-helpers.R @@ -471,20 +471,23 @@ test_that("h_find_interval works as expected for custom replacement", { }) test_that("default constructors exist for all subclasses of GeneralModel", { - classesToTest <- names(getClassDef("GeneralModel")@subclasses) - # Virtual class: throws exception - classesToTest <- classesToTest[which(!(classesToTest %in% c("DualEndpoint")))] + allModelSubclasses <- names(getClassDef("GeneralModel")@subclasses) + # Exceptions. + classesNotToTest <- c("DualEndpoint", "NeedsExtraProbModel") + classesToTest <- setdiff(allModelSubclasses, classesNotToTest) lapply( classesToTest, function(cls) { # Function exists - expect_true(length(findFunction(paste0(".Default", cls), where = asNamespace("crmPack"))) > 1) + expect_true( + length(findFunction(paste0(".Default", cls), where = asNamespace("crmPack"))) > 1, + label = cls + ) # Return value is of the correct class test_obj <- eval(parse(text = paste0(".Default", cls, "()"))) expect_class(test_obj, cls) } ) - expect_error(eval(parse(text = ".DefaultDualEndpoint()"))) }) test_that("default constructors exist for all subclasses of Increments", { @@ -692,3 +695,32 @@ test_that("calculations for percentages, given report_labels are not provided wo names(expected) <- character(0) expect_equal(result, expected) }) + +# h_group_data ---- + +test_that("h_group_data works as expected", { + mono_data <- h_get_data_1() + combo_data <- h_get_data_2() + group_data <- expect_silent(h_group_data(mono_data, combo_data)) + expect_valid(group_data, "DataGrouped") + expect_identical(mono_data@nObs + combo_data@nObs, group_data@nObs) + expect_identical(sort(union(mono_data@doseGrid, combo_data@doseGrid)), group_data@doseGrid) + mono_data_from_group <- cbind( + x = group_data@x[group_data@group == "mono"], + y = group_data@y[group_data@group == "mono"] + ) + mono_data_from_start <- cbind( + x = mono_data@x, + y = mono_data@y + ) + expect_setequal(mono_data_from_group, mono_data_from_start) + combo_data_from_group <- cbind( + x = group_data@x[group_data@group == "combo"], + y = group_data@y[group_data@group == "combo"] + ) + combo_data_from_start <- cbind( + x = combo_data@x, + y = combo_data@y + ) + expect_setequal(combo_data_from_group, combo_data_from_start) +})