From 7270a9ac78212339d1200f9c99a69314cb3fb640 Mon Sep 17 00:00:00 2001 From: Daniel Sabanes Bove Date: Tue, 12 Sep 2023 15:25:10 +0200 Subject: [PATCH 01/10] add class with constructors --- NAMESPACE | 4 + R/Model-class.R | 91 +++++++++++++++++++ .../Model-class-LogisticLogNormalGrouped.R | 6 ++ man/LogisticLogNormalGrouped-class.Rd | 55 +++++++++++ 4 files changed, 156 insertions(+) create mode 100644 examples/Model-class-LogisticLogNormalGrouped.R create mode 100644 man/LogisticLogNormalGrouped-class.Rd diff --git a/NAMESPACE b/NAMESPACE index 50bcac1df..5fc20e077 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -43,6 +43,7 @@ export(.DefaultIncrementsRelativeParts) export(.DefaultLogisticKadane) export(.DefaultLogisticKadaneBetaGamma) export(.DefaultLogisticLogNormal) +export(.DefaultLogisticLogNormalGrouped) export(.DefaultLogisticLogNormalMixture) export(.DefaultLogisticLogNormalSub) export(.DefaultLogisticNormal) @@ -112,6 +113,7 @@ export(.LogisticIndepBeta) export(.LogisticKadane) export(.LogisticKadaneBetaGamma) export(.LogisticLogNormal) +export(.LogisticLogNormalGrouped) export(.LogisticLogNormalMixture) export(.LogisticLogNormalSub) export(.LogisticNormal) @@ -210,6 +212,7 @@ export(LogisticIndepBeta) export(LogisticKadane) export(LogisticKadaneBetaGamma) export(LogisticLogNormal) +export(LogisticLogNormalGrouped) export(LogisticLogNormalMixture) export(LogisticLogNormalSub) export(LogisticNormal) @@ -400,6 +403,7 @@ exportClasses(LogisticIndepBeta) exportClasses(LogisticKadane) exportClasses(LogisticKadaneBetaGamma) exportClasses(LogisticLogNormal) +exportClasses(LogisticLogNormalGrouped) exportClasses(LogisticLogNormalMixture) exportClasses(LogisticLogNormalSub) exportClasses(LogisticNormal) diff --git a/R/Model-class.R b/R/Model-class.R index 44a53d052..5b08aeb15 100644 --- a/R/Model-class.R +++ b/R/Model-class.R @@ -516,6 +516,97 @@ ProbitLogNormalRel <- function(mean, cov, ref_dose = 1) { ProbitLogNormalRel(mean = c(-0.85, 1), cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)) } +# LogisticLogNormalGrouped ---- + +## class ---- + +#' `LogisticLogNormalGrouped` +#' +#' @description `r lifecycle::badge("experimental")` +#' +#' [`LogisticLogNormalGrouped`] is the class for a logistic regression model +#' for both the mono and the combo arms of the simultaneous dose escalation +#' design. +#' +#' @details The continuous covariate is the natural logarithm of the dose \eqn{x} divided by +#' the reference dose \eqn{x*} as in [`LogisticLogNormal`]. In addition, +#' \eqn{I_c} is a binary indicator covariate which is 1 for the combo arm and 0 for the mono arm. +#' The model is then defined as: +#' \deqn{logit[p(x)] = (alpha0 + I_c * delta0) + (alpha1 + I_c * delta1) * log(x / x*),} +#' where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}, +#' and `delta0` and `delta1` are the differences in the combo arm compared to the mono intercept +#' and slope parameters `alpha0` and `alpha1`. +#' The prior is defined as \deqn{(alpha0, log(delta0), log(alpha1), log(delta1)) ~ Normal(mean, cov).} +#' +#' @seealso [`ModelLogNormal`], [`LogisticLogNormal`]. +#' +#' @aliases LogisticLogNormalGrouped +#' @export +#' +.LogisticLogNormalGrouped <- setClass( + Class = "LogisticLogNormalGrouped", + contains = "ModelLogNormal" +) + +## constructor ---- + +#' @rdname LogisticLogNormalGrouped-class +#' +#' @inheritParams ModelLogNormal +#' +#' @export +#' @example examples/Model-class-LogisticLogNormalGrouped.R +#' +LogisticLogNormalGrouped <- function(mean, cov, ref_dose = 1) { + params <- ModelParamsNormal(mean, cov) + .LogisticLogNormalGrouped( + params = params, + ref_dose = 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") + ) +} + +## default constructor ---- + +#' @rdname LogisticLogNormalGrouped-class +#' @note Typically, end users will not use the `.DefaultLogisticLogNormalGrouped()` function. +#' @export +.DefaultLogisticLogNormalGrouped <- function() { + LogisticLogNormalGrouped( + mean = rep(0, 4), + cov = diag(rep(1, 4)), + ) +} + # LogisticKadane ---- ## class ---- diff --git a/examples/Model-class-LogisticLogNormalGrouped.R b/examples/Model-class-LogisticLogNormalGrouped.R new file mode 100644 index 000000000..acae7d244 --- /dev/null +++ b/examples/Model-class-LogisticLogNormalGrouped.R @@ -0,0 +1,6 @@ +my_model <- LogisticLogNormalGrouped( + mean = c(-0.85, 0, 1, 0), + cov = diag(1, 4), + ref_dose = 50 +) +my_model diff --git a/man/LogisticLogNormalGrouped-class.Rd b/man/LogisticLogNormalGrouped-class.Rd new file mode 100644 index 000000000..550b0d920 --- /dev/null +++ b/man/LogisticLogNormalGrouped-class.Rd @@ -0,0 +1,55 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Model-class.R +\docType{class} +\name{LogisticLogNormalGrouped-class} +\alias{LogisticLogNormalGrouped-class} +\alias{.LogisticLogNormalGrouped} +\alias{LogisticLogNormalGrouped} +\alias{.DefaultLogisticLogNormalGrouped} +\title{\code{LogisticLogNormalGrouped}} +\usage{ +LogisticLogNormalGrouped(mean, cov, ref_dose = 1) + +.DefaultLogisticLogNormalGrouped() +} +\arguments{ +\item{mean}{(\code{numeric})\cr the prior mean vector.} + +\item{cov}{(\code{matrix})\cr the prior covariance matrix. The precision matrix +\code{prec} is internally calculated as an inverse of \code{cov}.} + +\item{ref_dose}{(\code{number})\cr the reference dose \eqn{x*} (strictly positive +number).} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +\code{\link{LogisticLogNormalGrouped}} is the class for a logistic regression model +for both the mono and the combo arms of the simultaneous dose escalation +design. +} +\details{ +The continuous covariate is the natural logarithm of the dose \eqn{x} divided by +the reference dose \eqn{x*} as in \code{\link{LogisticLogNormal}}. In addition, +\eqn{I_c} is a binary indicator covariate which is 1 for the combo arm and 0 for the mono arm. +The model is then defined as: +\deqn{logit[p(x)] = (alpha0 + I_c * delta0) + (alpha1 + I_c * delta1) * log(x / x*),} +where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}, +and \code{delta0} and \code{delta1} are the differences in the combo arm compared to the mono intercept +and slope parameters \code{alpha0} and \code{alpha1}. +The prior is defined as \deqn{(alpha0, log(delta0), log(alpha1), log(delta1)) ~ Normal(mean, cov).} +} +\note{ +Typically, end users will not use the \code{.DefaultLogisticLogNormalGrouped()} function. +} +\examples{ +my_model <- LogisticLogNormalGrouped( + mean = c(-0.85, 0, 1, 0), + cov = diag(1, 4), + ref_dose = 50 +) +my_model +} +\seealso{ +\code{\link{ModelLogNormal}}, \code{\link{LogisticLogNormal}}. +} From 74ab10125d651db3a094626ddd7800f1587790c6 Mon Sep 17 00:00:00 2001 From: Daniel Sabanes Bove Date: Tue, 12 Sep 2023 15:55:31 +0200 Subject: [PATCH 02/10] add tests for model class --- tests/testthat/_snaps/Model-class.md | 36 ++++++++++++++++++++++++ tests/testthat/test-Model-class.R | 42 ++++++++++++++++++++++++++++ 2 files changed, 78 insertions(+) diff --git a/tests/testthat/_snaps/Model-class.md b/tests/testthat/_snaps/Model-class.md index d50f57c6d..8f0ab4dfc 100644 --- a/tests/testthat/_snaps/Model-class.md +++ b/tests/testthat/_snaps/Model-class.md @@ -118,6 +118,42 @@ [1] 2.6848927 0.5973656 0.5178854 4.1900261 +# MCMC computes correct values for LogisticLogNormalGrouped model + + Code + result@data + Output + $alpha0 + [1] -1.848124 -1.848124 -2.195992 -2.195992 + + $alpha1 + [1] 0.08165851 0.08165851 0.31496464 0.31496464 + + $delta0 + [1] 0.1263061 0.1263061 0.1112928 0.1112928 + + $delta1 + [1] 0.06280840 0.06280840 0.09082656 0.09082656 + + +# MCMC computes correct values for LogisticLogNormalGrouped model and empty data + + Code + result@data + Output + $alpha0 + [1] -0.7258644 -2.3268647 1.2196258 0.9135351 + + $alpha1 + [1] 1.3236188 0.2700508 1.8853673 0.2820018 + + $delta0 + [1] 3.4298468 2.0426447 0.7105671 0.2355593 + + $delta1 + [1] 0.3087583 0.2956680 3.1296169 1.7350122 + + # MCMC computes correct values for LogisticKadane model Code diff --git a/tests/testthat/test-Model-class.R b/tests/testthat/test-Model-class.R index c47bec12a..ddba621bf 100644 --- a/tests/testthat/test-Model-class.R +++ b/tests/testthat/test-Model-class.R @@ -279,6 +279,48 @@ test_that("MCMC computes correct values for ProbitLogNormalRel model and empty d expect_snapshot(result@data) }) +# LogisticLogNormalGrouped ---- + +## constructor ---- + +test_that("LogisticLogNormalGrouped object can be created with user constructor", { + result <- expect_silent( + LogisticLogNormalGrouped( + mean = 1:4, + cov = diag(1:4, 4), + ref_dose = 2 + ) + ) + expect_valid(result, "LogisticLogNormalGrouped") +}) + +test_that(".DefaultLogisticLogNormalGrouped works as expected", { + expect_valid( + .DefaultLogisticLogNormalGrouped(), + "LogisticLogNormalGrouped" + ) +}) + +## mcmc ---- + +test_that("MCMC computes correct values for LogisticLogNormalGrouped model", { + data <- h_get_data_grouped() + model <- .DefaultLogisticLogNormalGrouped() + options <- h_get_mcmc_options() + + result <- mcmc(data = data, model = model, options = options) + expect_snapshot(result@data) +}) + +test_that("MCMC computes correct values for LogisticLogNormalGrouped model and empty data", { + data <- h_get_data_grouped(empty = TRUE) + model <- .DefaultLogisticLogNormalGrouped() + options <- h_get_mcmc_options() + + result <- mcmc(data = data, model = model, options = options) + expect_snapshot(result@data) +}) + # LogisticKadane ---- ## constructor ---- From e297b7742ffd007ad3181f1a6dfefea37abe6b4a Mon Sep 17 00:00:00 2001 From: Daniel Sabanes Bove Date: Tue, 12 Sep 2023 20:23:31 +0200 Subject: [PATCH 03/10] add prob method --- R/Model-methods.R | 35 ++++++++++++++++++++++++++++ man/prob.Rd | 11 +++++++++ tests/testthat/test-Model-methods.R | 36 +++++++++++++++++++++++++++++ 3 files changed, 82 insertions(+) diff --git a/R/Model-methods.R b/R/Model-methods.R index 4a6bfa975..ae0259d2f 100644 --- a/R/Model-methods.R +++ b/R/Model-methods.R @@ -923,6 +923,41 @@ setMethod( } ) +## LogisticLogNormalGrouped ---- + +#' @describeIn prob method for [`LogisticLogNormalGrouped`] which needs `group` +#' argument in addition. +#' @param group (`character` or `factor`)\cr for [`LogisticLogNormalGrouped`], +#' indicating whether to calculate the probability for the `mono` or for +#' the `combo` arm. +#' @aliases prob-LogisticLogNormalGrouped +#' @export +#' +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_multi_class(group, c("character", "factor")) + assert_subset(as.character(group), choices = c("mono", "combo")) + assert_length(group, len = size(samples)) + + 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)) + } +) + ## LogisticKadane ---- #' @describeIn prob diff --git a/man/prob.Rd b/man/prob.Rd index 82684fcca..48450c936 100644 --- a/man/prob.Rd +++ b/man/prob.Rd @@ -12,6 +12,8 @@ \alias{prob-ProbitLogNormal} \alias{prob,numeric,ProbitLogNormalRel,Samples-method} \alias{prob-ProbitLogNormalRel} +\alias{prob,numeric,LogisticLogNormalGrouped,Samples-method} +\alias{prob-LogisticLogNormalGrouped} \alias{prob,numeric,LogisticKadane,Samples-method} \alias{prob-LogisticKadane} \alias{prob,numeric,LogisticKadaneBetaGamma,Samples-method} @@ -46,6 +48,8 @@ prob(dose, model, samples, ...) \S4method{prob}{numeric,ProbitLogNormalRel,Samples}(dose, model, samples) +\S4method{prob}{numeric,LogisticLogNormalGrouped,Samples}(dose, model, samples, group) + \S4method{prob}{numeric,LogisticKadane,Samples}(dose, model, samples) \S4method{prob}{numeric,LogisticKadaneBetaGamma,Samples}(dose, model, samples) @@ -80,6 +84,10 @@ dose escalation or pseudo DLE (dose-limiting events)/toxicity model.} used to compute toxicity probabilities. Can also be missing for some models.} \item{...}{model specific parameters when \code{samples} are not used.} + +\item{group}{(\code{character} or \code{factor})\cr for \code{\link{LogisticLogNormalGrouped}}, +indicating whether to calculate the probability for the \code{mono} or for +the \code{combo} arm.} } \value{ A \code{proportion} or \code{numeric} vector with the toxicity probabilities. @@ -115,6 +123,9 @@ correspond to the sampling index, i.e. the layout is then \item \code{prob(dose = numeric, model = ProbitLogNormalRel, samples = Samples)}: +\item \code{prob(dose = numeric, model = LogisticLogNormalGrouped, samples = Samples)}: method for \code{\link{LogisticLogNormalGrouped}} which needs \code{group} +argument in addition. + \item \code{prob(dose = numeric, model = LogisticKadane, samples = Samples)}: \item \code{prob(dose = numeric, model = LogisticKadaneBetaGamma, samples = Samples)}: diff --git a/tests/testthat/test-Model-methods.R b/tests/testthat/test-Model-methods.R index e02832338..f5b45dab1 100644 --- a/tests/testthat/test-Model-methods.R +++ b/tests/testthat/test-Model-methods.R @@ -1113,6 +1113,42 @@ test_that("prob-ProbitLogNormalRel throws the error when dose is not valid", { ) }) +## LogisticLogNormalGrouped ---- + +test_that("prob-LogisticLogNormalGrouped works as expected", { + model <- .DefaultLogisticLogNormalGrouped() + samples <- h_as_samples(list( + alpha0 = c(0, -1, 1, 2), + delta0 = c(0, 1, -1, 0), + alpha1 = c(0, 0.5, 1, -1), + delta1 = c(1, 0, -1, 2) + )) + + result <- prob(10, model, samples, group = "mono") + expect_equal(result, c(0.5, 0.5378, 0.9645, 0.4249), tolerance = 1e-4) +}) + +test_that("prob-LogisticLogNormalGrouped works as expected for scalar samples", { + model <- .DefaultLogisticLogNormalGrouped() + samples <- h_as_samples(list(alpha0 = 1, delta0 = -1, alpha1 = 1, delta1 = -0.5)) + + result <- prob(c(1, 30), model, samples, group = "combo") + expect_equal(result, c(0.5, 0.8456), tolerance = 1e-4) +}) + +test_that("prob-LogisticLogNormalGrouped works as expected for vectors", { + model <- .DefaultLogisticLogNormalGrouped() + samples <- h_as_samples(list( + alpha0 = c(1, 2), + delta0 = c(0.5, -0.5), + alpha1 = c(0, 1), + delta1 = c(1, 0.2) + )) + + result <- prob(c(1, 30), model, samples, group = c("mono", "combo")) + expect_equal(result, c(0.7311, 0.9962), tolerance = 1e-4) +}) + ## LogisticKadane ---- test_that("prob-LogisticKadane works as expected", { From c4c2342040c72390f695ae7ea7117a7159a57646 Mon Sep 17 00:00:00 2001 From: Daniel Sabanes Bove Date: Tue, 12 Sep 2023 20:31:32 +0200 Subject: [PATCH 04/10] progress --- R/Model-methods.R | 35 ++++++++++++++++++++++++++ tests/testthat/test-Model-methods.R | 39 +++++++++++++++++++++++++++++ 2 files changed, 74 insertions(+) diff --git a/R/Model-methods.R b/R/Model-methods.R index ae0259d2f..504a2b0e9 100644 --- a/R/Model-methods.R +++ b/R/Model-methods.R @@ -403,6 +403,41 @@ setMethod( } ) +## LogisticLogNormalGrouped ---- + +#' @describeIn dose method for [`LogisticLogNormalGrouped`] which needs `group` +#' argument in addition. +#' @param group (`character` or `factor`)\cr for [`LogisticLogNormalGrouped`], +#' indicating whether to calculate the dose for the `mono` or for +#' the `combo` arm. +#' @aliases dose-LogisticLogNormalGrouped +#' @export +#' +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_multi_class(group, c("character", "factor")) + assert_subset(as.character(group), choices = c("mono", "combo")) + assert_length(group, len = size(samples)) + + 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 + } +) + ## LogisticKadane ---- #' @describeIn dose compute the dose level reaching a specific target diff --git a/tests/testthat/test-Model-methods.R b/tests/testthat/test-Model-methods.R index f5b45dab1..d98fd2d6a 100644 --- a/tests/testthat/test-Model-methods.R +++ b/tests/testthat/test-Model-methods.R @@ -504,6 +504,45 @@ test_that("dose-ProbitLogNormalRel throws the error when x is not valid", { ) }) +## LogisticLogNormalGrouped ---- + +test_that("dose-LogisticLogNormalGrouped works as expected", { + model <- .DefaultLogisticLogNormalGrouped() + samples <- h_as_samples(list( + alpha0 = c(0.1, -1, 1, 2), + delta0 = c(0, 1, -1, 0), + alpha1 = c(0, 0.5, 1, -1), + delta1 = c(1, 0, -0.9, 2) + )) + + result_mono <- dose(0.5, model, samples, group = "mono") + result_combo <- dose(0.5, model, samples, group = "combo") + + expect_equal(result_mono, c(0, 7.3891, 0.3679, 7.3891), tolerance = 1e-4) + expect_equal(result_combo, c(0.9048, 1, 1, 0.1353), tolerance = 1e-4) +}) + +test_that("dose-LogisticLogNormalGrouped works as expected for scalar samples", { + model <- .DefaultLogisticLogNormalGrouped() + samples <- h_as_samples(list(alpha0 = 1, delta0 = -1, alpha1 = 1, delta1 = -0.5)) + + result <- dose(c(1, 30), model, samples, group = "combo") + expect_equal(result, c(0.5, 0.8456), tolerance = 1e-4) +}) + +test_that("dose-LogisticLogNormalGrouped works as expected for vectors", { + model <- .DefaultLogisticLogNormalGrouped() + samples <- h_as_samples(list( + alpha0 = c(1, 2), + delta0 = c(0.5, -0.5), + alpha1 = c(0, 1), + delta1 = c(1, 0.2) + )) + + result <- dose(c(1, 30), model, samples, group = c("mono", "combo")) + expect_equal(result, c(0.7311, 0.9962), tolerance = 1e-4) +}) + ## LogisticKadane ---- test_that("dose-LogisticKadane works as expected", { From 697bb7be65be4ae7f4a725508e8bfce7669563c6 Mon Sep 17 00:00:00 2001 From: Daniel Sabanes Bove Date: Wed, 13 Sep 2023 09:54:26 +0200 Subject: [PATCH 05/10] dose and prob function generics result now pass through add. args --- R/Model-methods.R | 8 +++--- man/dose.Rd | 11 ++++++++ tests/testthat/test-Model-methods.R | 40 ++++++++++++++++++++++++++--- 3 files changed, 51 insertions(+), 8 deletions(-) diff --git a/R/Model-methods.R b/R/Model-methods.R index 504a2b0e9..042575579 100644 --- a/R/Model-methods.R +++ b/R/Model-methods.R @@ -50,8 +50,8 @@ setMethod( data = model_params, options = McmcOptions(samples = NROW(model_params[[1]])) ) - function(x) { - dose(x = x, model = model, samples = samples) + function(x, ...) { + dose(x = x, model = model, samples = samples, ...) } } ) @@ -127,8 +127,8 @@ setMethod( data = model_params, options = McmcOptions(samples = NROW(model_params[[1]])) ) - function(dose) { - prob(dose = dose, model = model, samples = samples) + function(dose, ...) { + prob(dose = dose, model = model, samples = samples, ...) } } ) diff --git a/man/dose.Rd b/man/dose.Rd index 7c97c5d22..9ad8202fe 100644 --- a/man/dose.Rd +++ b/man/dose.Rd @@ -12,6 +12,8 @@ \alias{dose-ProbitLogNormal} \alias{dose,numeric,ProbitLogNormalRel,Samples-method} \alias{dose-ProbitLogNormalRel} +\alias{dose,numeric,LogisticLogNormalGrouped,Samples-method} +\alias{dose-LogisticLogNormalGrouped} \alias{dose,numeric,LogisticKadane,Samples-method} \alias{dose-LogisticKadane} \alias{dose,numeric,LogisticKadaneBetaGamma,Samples-method} @@ -50,6 +52,8 @@ dose(x, model, samples, ...) \S4method{dose}{numeric,ProbitLogNormalRel,Samples}(x, model, samples) +\S4method{dose}{numeric,LogisticLogNormalGrouped,Samples}(x, model, samples, group) + \S4method{dose}{numeric,LogisticKadane,Samples}(x, model, samples) \S4method{dose}{numeric,LogisticKadaneBetaGamma,Samples}(x, model, samples) @@ -88,6 +92,10 @@ as the sample.} used to compute the resulting doses. Can also be missing for some models.} \item{...}{model specific parameters when \code{samples} are not used.} + +\item{group}{(\code{character} or \code{factor})\cr for \code{\link{LogisticLogNormalGrouped}}, +indicating whether to calculate the dose for the \code{mono} or for +the \code{combo} arm.} } \value{ A \code{number} or \code{numeric} vector with the doses. @@ -133,6 +141,9 @@ probability of the occurrence of a DLE (\code{x}). \item \code{dose(x = numeric, model = ProbitLogNormalRel, samples = Samples)}: compute the dose level reaching a specific target probability of the occurrence of a DLE (\code{x}). +\item \code{dose(x = numeric, model = LogisticLogNormalGrouped, samples = Samples)}: method for \code{\link{LogisticLogNormalGrouped}} which needs \code{group} +argument in addition. + \item \code{dose(x = numeric, model = LogisticKadane, samples = Samples)}: compute the dose level reaching a specific target probability of the occurrence of a DLE (\code{x}). diff --git a/tests/testthat/test-Model-methods.R b/tests/testthat/test-Model-methods.R index d98fd2d6a..1930ff5d1 100644 --- a/tests/testthat/test-Model-methods.R +++ b/tests/testthat/test-Model-methods.R @@ -11,7 +11,7 @@ test_that("doseFunction-GeneralModel returns correct dose function", { dose_fun_env <- environment(dose_fun) expect_function(doseFunction, args = c("model", "..."), null.ok = FALSE) - expect_function(dose_fun, args = "x", nargs = 1, null.ok = FALSE) + expect_function(dose_fun, args = c("x", "..."), null.ok = FALSE) # Body of `dose_fun` must be a `dose` method with `x`, `model` and `samples` args. dose_fun_body <- as.list(body(dose_fun)[[2]]) @@ -52,7 +52,7 @@ test_that("doseFunction-GeneralModel returns correct dose function for matrix pa dose_fun_env <- environment(dose_fun) expect_function(doseFunction, args = c("model", "..."), null.ok = FALSE) - expect_function(dose_fun, args = "x", nargs = 1, null.ok = FALSE) + expect_function(dose_fun, args = c("x", "..."), null.ok = FALSE) # Body of `dose_fun` must be a `dose` method with `x`, `model` and `samples` args. dose_fun_body <- as.list(body(dose_fun))[[2]] @@ -119,6 +119,22 @@ test_that("doseFunction-ModelPseudo throws the error when no params are provided ) }) +## LogisticLogNormalGrouped ---- + +test_that("doseFunction-LogisticLogNormalGrouped works as expected", { + model <- .DefaultLogisticLogNormalGrouped() + + dose_fun <- expect_silent(doseFunction( + model, alpha0 = 1, delta0 = 0.5, alpha1 = 0.5, delta1 = -0.2 + )) + dose_fun <- h_covr_detrace(dose_fun) + + expect_function(dose_fun, args = c("x", "..."), null.ok = FALSE) + expect_error(dose_fun(1), "argument \"group\" is missing, with no default") + result <- expect_silent(dose_fun(0.5, group = "mono")) + expect_equal(result, 0.13534, tolerance = 1e-4) +}) + # probFunction ---- ## GeneralModel ---- @@ -132,7 +148,7 @@ test_that("probFunction-GeneralModel returns correct prob function", { prob_fun_env <- environment(prob_fun) expect_function(probFunction, args = c("model", "..."), null.ok = FALSE) - expect_function(prob_fun, args = "dose", nargs = 1, null.ok = FALSE) + expect_function(prob_fun, args = c("dose", "..."), null.ok = FALSE) # Body of `prob_fun` must be a `prob` method with `dose`, `model` and `samples` args. prob_fun_body <- as.list(body(prob_fun)[[2]]) @@ -173,7 +189,7 @@ test_that("probFunction-GeneralModel returns correct prob function for matrix pa prob_fun_env <- environment(prob_fun) expect_function(probFunction, args = c("model", "..."), null.ok = FALSE) - expect_function(prob_fun, args = "dose", nargs = 1, null.ok = FALSE) + expect_function(prob_fun, args = c("dose", "..."), null.ok = FALSE) # Body of `prob_fun` must be a `prob` method with `dose`, `model` and `samples` args. prob_fun_body <- as.list(body(prob_fun)[[2]]) @@ -239,6 +255,22 @@ test_that("probFunction-ModelTox throws the error when no params are provided", ) }) +## LogisticLogNormalGrouped ---- + +test_that("probFunction-LogisticLogNormalGrouped works as expected", { + model <- .DefaultLogisticLogNormalGrouped() + + prob_fun <- expect_silent(probFunction( + model, alpha0 = 1, delta0 = 0.5, alpha1 = 0.5, delta1 = -0.2 + )) + prob_fun <- h_covr_detrace(prob_fun) + + expect_function(prob_fun, args = c("dose", "..."), null.ok = FALSE) + expect_error(prob_fun(1), "argument \"group\" is missing, with no default") + result <- expect_silent(prob_fun(10, group = "mono")) + expect_equal(result, 0.8958, tolerance = 1e-4) +}) + # efficacyFunction ---- ## ModelEff ---- From b8717453ada5a683e713ad0bf3fee996d73bda55 Mon Sep 17 00:00:00 2001 From: Daniel Sabanes Bove Date: Wed, 13 Sep 2023 10:04:44 +0200 Subject: [PATCH 06/10] fit and plot method tests --- .../plot-samples-logisticlognormalgrouped.svg | 66 +++++++++++++++++++ tests/testthat/test-Samples-methods.R | 32 +++++++++ 2 files changed, 98 insertions(+) create mode 100644 tests/testthat/_snaps/Samples-methods/plot-samples-logisticlognormalgrouped.svg diff --git a/tests/testthat/_snaps/Samples-methods/plot-samples-logisticlognormalgrouped.svg b/tests/testthat/_snaps/Samples-methods/plot-samples-logisticlognormalgrouped.svg new file mode 100644 index 000000000..0ad3dfc68 --- /dev/null +++ b/tests/testthat/_snaps/Samples-methods/plot-samples-logisticlognormalgrouped.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +25 +50 +75 +100 + + + + + + + + + +2.5 +5.0 +7.5 +10.0 +Dose level +Probability of DLT [%] + +Type + + + + +Estimate +95% Credible Interval +plot-Samples-LogisticLogNormalGrouped + + diff --git a/tests/testthat/test-Samples-methods.R b/tests/testthat/test-Samples-methods.R index e78424553..df22d5ec2 100644 --- a/tests/testthat/test-Samples-methods.R +++ b/tests/testthat/test-Samples-methods.R @@ -217,6 +217,23 @@ test_that("fit-Samples forwards additional arguments to prob inside", { expect_named(result, c("dose", "middle", "lower", "upper")) }) +## Samples-LogisticLogNormalGrouped ---- + +test_that("fit-Samples works specifically also for LogisticLogNormalGrouped", { + mcmcOptions <- McmcOptions(samples = 3) + samples <- Samples( + data = list(alpha0 = -1:1, delta0 = c(0, 1, -1), alpha1 = -1:1, delta1 = c(-1, 0, 2)), + options = mcmcOptions + ) + model <- .DefaultLogisticLogNormalGrouped() + emptyData <- Data(doseGrid = seq(10, 80, 10)) + + result <- expect_silent(fit(samples, model, emptyData, group = "combo")) + 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", { @@ -869,6 +886,21 @@ test_that("Check that plot-Samples-ModelTox works correctly", { vdiffr::expect_doppelganger("plot-Samples-ModelTox_showlegend-FALSE", actual1) }) +## Samples-LogisticLogNormalGrouped ---- + +test_that("plot-Samples works specifically also for LogisticLogNormalGrouped", { + mcmcOptions <- McmcOptions(samples = 3) + samples <- Samples( + data = list(alpha0 = -1:1, delta0 = c(0, 1, -1), alpha1 = -1:1, delta1 = c(-1, 0, 2)), + options = mcmcOptions + ) + model <- .DefaultLogisticLogNormalGrouped() + emptyData <- Data(doseGrid = seq(0.5, 10, by = 0.1)) + + result <- expect_silent(plot(samples, model, emptyData, group = "combo")) + vdiffr::expect_doppelganger("plot-Samples-LogisticLogNormalGrouped", result) +}) + ## Samples-DataDual ---- test_that("Check that plot-Samples-ModelEff fails gracefully with bad input", { From f2cb21fe05365df599408943434fa1b3a65adf2f Mon Sep 17 00:00:00 2001 From: Daniel Sabanes Bove Date: Wed, 13 Sep 2023 10:07:17 +0200 Subject: [PATCH 07/10] remove dummy tests because now we have the actual ones --- tests/testthat/test-Samples-methods.R | 22 ---------------------- 1 file changed, 22 deletions(-) diff --git a/tests/testthat/test-Samples-methods.R b/tests/testthat/test-Samples-methods.R index df22d5ec2..427bb4faf 100644 --- a/tests/testthat/test-Samples-methods.R +++ b/tests/testthat/test-Samples-methods.R @@ -205,18 +205,6 @@ 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-LogisticLogNormalGrouped ---- test_that("fit-Samples works specifically also for LogisticLogNormalGrouped", { @@ -396,16 +384,6 @@ 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), From 75380124beefc64559a9079093590f061690f11a Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 13 Sep 2023 08:11:57 +0000 Subject: [PATCH 08/10] [skip actions] Restyle files --- tests/testthat/test-Model-methods.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-Model-methods.R b/tests/testthat/test-Model-methods.R index 1930ff5d1..0f9f27cf8 100644 --- a/tests/testthat/test-Model-methods.R +++ b/tests/testthat/test-Model-methods.R @@ -125,7 +125,8 @@ test_that("doseFunction-LogisticLogNormalGrouped works as expected", { model <- .DefaultLogisticLogNormalGrouped() dose_fun <- expect_silent(doseFunction( - model, alpha0 = 1, delta0 = 0.5, alpha1 = 0.5, delta1 = -0.2 + model, + alpha0 = 1, delta0 = 0.5, alpha1 = 0.5, delta1 = -0.2 )) dose_fun <- h_covr_detrace(dose_fun) @@ -261,7 +262,8 @@ test_that("probFunction-LogisticLogNormalGrouped works as expected", { model <- .DefaultLogisticLogNormalGrouped() prob_fun <- expect_silent(probFunction( - model, alpha0 = 1, delta0 = 0.5, alpha1 = 0.5, delta1 = -0.2 + model, + alpha0 = 1, delta0 = 0.5, alpha1 = 0.5, delta1 = -0.2 )) prob_fun <- h_covr_detrace(prob_fun) From d2eaa63a27d5c2b26471f276b4dda0d552c70d04 Mon Sep 17 00:00:00 2001 From: Daniel Sabanes Bove Date: Wed, 13 Sep 2023 10:14:56 +0200 Subject: [PATCH 09/10] remove indentation linter because it is not in defaults to avoid warn --- .lintr | 1 - 1 file changed, 1 deletion(-) diff --git a/.lintr b/.lintr index 0a19bc3fd..7049743a2 100644 --- a/.lintr +++ b/.lintr @@ -3,6 +3,5 @@ linters: linters_with_defaults( cyclocomp_linter = NULL, object_usage_linter = NULL, object_length_linter = NULL, - indentation_linter = NULL, object_name_linter = object_name_linter(c("CamelCase", "camelCase", "snake_case")) ) From 3a4fdf31d16efaaba6215c4d112492cb02ba03b0 Mon Sep 17 00:00:00 2001 From: Daniel Sabanes Bove Date: Wed, 13 Sep 2023 15:30:44 +0200 Subject: [PATCH 10/10] polishing --- R/crmPack-package.R | 5 ++++- _pkgdown.yaml | 1 + tests/testthat/test-Model-methods.R | 10 +++++----- 3 files changed, 10 insertions(+), 6 deletions(-) diff --git a/R/crmPack-package.R b/R/crmPack-package.R index 5a5385bf2..44fbf1ee0 100644 --- a/R/crmPack-package.R +++ b/R/crmPack-package.R @@ -81,7 +81,9 @@ globalVariables(c( "logit<-", "rho0", "alpha0", + "delta0", "alpha1", + "delta1", "inverse", "priorCov", "theta", @@ -135,7 +137,8 @@ globalVariables(c( "ref_dose", "comp", "X", - "skel_probs" + "skel_probs", + "is_combo" )) # nolint end diff --git a/_pkgdown.yaml b/_pkgdown.yaml index fdfdab0e1..91b3857a8 100644 --- a/_pkgdown.yaml +++ b/_pkgdown.yaml @@ -51,6 +51,7 @@ reference: - LogisticLogNormalSub - ProbitLogNormal - ProbitLogNormalRel + - LogisticLogNormalGrouped - LogisticKadane - LogisticKadaneBetaGamma - LogisticNormalMixture diff --git a/tests/testthat/test-Model-methods.R b/tests/testthat/test-Model-methods.R index 0f9f27cf8..7e4a5cc54 100644 --- a/tests/testthat/test-Model-methods.R +++ b/tests/testthat/test-Model-methods.R @@ -560,8 +560,8 @@ test_that("dose-LogisticLogNormalGrouped works as expected for scalar samples", model <- .DefaultLogisticLogNormalGrouped() samples <- h_as_samples(list(alpha0 = 1, delta0 = -1, alpha1 = 1, delta1 = -0.5)) - result <- dose(c(1, 30), model, samples, group = "combo") - expect_equal(result, c(0.5, 0.8456), tolerance = 1e-4) + result <- dose(c(0.2, 0.8), model, samples, group = "combo") + expect_equal(result, c(0.0625, 16), tolerance = 1e-4) }) test_that("dose-LogisticLogNormalGrouped works as expected for vectors", { @@ -569,12 +569,12 @@ test_that("dose-LogisticLogNormalGrouped works as expected for vectors", { samples <- h_as_samples(list( alpha0 = c(1, 2), delta0 = c(0.5, -0.5), - alpha1 = c(0, 1), + alpha1 = c(0.5, 1), delta1 = c(1, 0.2) )) - result <- dose(c(1, 30), model, samples, group = c("mono", "combo")) - expect_equal(result, c(0.7311, 0.9962), tolerance = 1e-4) + result <- dose(c(0.4, 0.8), model, samples, group = c("mono", "combo")) + expect_equal(result, c(0.0601, 0.9096), tolerance = 1e-4) }) ## LogisticKadane ----