# nolint start
#' @include helpers.R
#' @include Rules-validity.R
NULL
## ============================================================
## --------------------------------------------------
## Virtual class for finding next best dose
## --------------------------------------------------
##' The virtual class for finding next best dose
##'
##' @seealso \code{\linkS4class{NextBestMTD}},
##' \code{\linkS4class{NextBestNCRM}},
##' \code{\linkS4class{NextBestDualEndpoint}},
##' \code{\linkS4class{NextBestThreePlusThree}}
##'
##' @export
##' @keywords classes
setClass(Class="NextBest",
contains=list("VIRTUAL"))
## --------------------------------------------------
## Next best dose based on MTD estimate
## --------------------------------------------------
##' The class with the input for finding the next best MTD estimate
##'
##' @slot target the target toxicity probability
##' @slot derive the function which derives from the input, a vector of
##' posterior MTD samples called \code{mtdSamples}, the final next best MTD
##' estimate.
##'
##' @example examples/Rules-class-NextBestMTD.R
##' @export
##' @keywords classes
.NextBestMTD <-
setClass(Class="NextBestMTD",
representation(target="numeric",
derive="function"),
prototype(target=0.3,
derive=
function(mtdSamples){
quantile(mtdSamples,
probs=0.3)}),
contains=list("NextBest"),
validity=
function(object){
o <- Validate()
o$check(is.probability(object@target,
bounds=FALSE),
"target must be probability > 0 and < 1")
o$check(identical(names(formals(object@derive)),
c("mtdSamples")),
"derive must have as single argument 'mtdSamples'")
o$result()
})
validObject(.NextBestMTD())
##' Initialization function for class "NextBestMTD"
##'
##' @param target see \code{\linkS4class{NextBestMTD}}
##' @param derive see \code{\linkS4class{NextBestMTD}}
##' @return the \code{\linkS4class{NextBestMTD}} object
##'
##' @export
##' @keywords methods
NextBestMTD <- function(target,
derive)
{
.NextBestMTD(target=target,
derive=derive)
}
## --------------------------------------------------
## Next best dose based on NCRM rule
## --------------------------------------------------
##' The class with the input for finding the next dose in target interval
##'
##' Note that to avoid numerical problems, the dose selection algorithm has been
##' implemented as follows: First admissible doses are found, which are those
##' with probability to fall in \code{overdose} category being below
##' \code{maxOverdoseProb}. Next, within the admissible doses, the maximum
##' probability to fall in the \code{target} category is calculated. If that is
##' above 5% (i.e., it is not just numerical error), then the corresponding
##' dose is the next recommended dose. Otherwise, the highest admissible dose is
##' the next recommended dose.
##'
##' @slot target the target toxicity interval (limits included)
##' @slot overdose the overdose toxicity interval (lower limit excluded, upper
##' limit included)
##' @slot maxOverdoseProb maximum overdose probability that is allowed
##'
##' @example examples/Rules-class-NextBestNCRM.R
##' @export
##' @keywords classes
.NextBestNCRM <-
setClass(Class="NextBestNCRM",
representation(target="numeric",
overdose="numeric",
maxOverdoseProb="numeric"),
prototype(target=c(0.2, 0.35),
overdose=c(0.35, 1),
maxOverdoseProb=0.25),
contains=list("NextBest"),
validity=
function(object){
o <- Validate()
o$check(is.probRange(object@target),
"target has to be a probability range")
o$check(is.probRange(object@overdose),
"overdose has to be a probability range")
o$check(is.probability(object@maxOverdoseProb),
"maxOverdoseProb has to be a probability")
o$result()
})
validObject(.NextBestNCRM())
##' Initialization function for "NextBestNCRM"
##'
##' @param target see \code{\linkS4class{NextBestNCRM}}
##' @param overdose see \code{\linkS4class{NextBestNCRM}}
##' @param maxOverdoseProb see \code{\linkS4class{NextBestNCRM}}
##' @return the \code{\linkS4class{NextBestNCRM}} object
##'
##' @export
##' @keywords methods
NextBestNCRM <- function(target,
overdose,
maxOverdoseProb)
{
.NextBestNCRM(target=target,
overdose=overdose,
maxOverdoseProb=maxOverdoseProb)
}
## --------------------------------------------------
## Next best dose based on 3+3 rule
## --------------------------------------------------
##' The class with the input for finding the next dose in target interval
##'
##' Implements the classical 3+3 dose recommendation.
##' No input is required, hence this class has no slots.
##'
##' @example examples/Rules-class-NextBestThreePlusThree.R
##' @export
##' @keywords classes
.NextBestThreePlusThree <-
setClass(Class="NextBestThreePlusThree",
contains=list("NextBest"))
##' Initialization function for "NextBestThreePlusThree"
##'
##' @return the \code{\linkS4class{NextBestThreePlusThree}} object
##'
##' @export
##' @keywords methods
NextBestThreePlusThree <- function()
{
.NextBestThreePlusThree()
}
## --------------------------------------------------
## Next best dose based on dual endpoint model
## --------------------------------------------------
##' The class with the input for finding the next dose
##' based on the dual endpoint model
##'
##' This rule first excludes all doses that exceed the probability
##' \code{maxOverdoseProb} of having an overdose toxicity, as specified by the
##' overdose interval \code{overdose}. Then, it picks under the remaining
##' admissible doses the one that maximizes the probability to be in the
##' \code{target} biomarker range, by default relative to the maximum biomarker level
##' across the dose grid or relative to the Emax parameter in case a parametric
##' model was selected (e.g. \code{\linkS4class{DualEndpointBeta}},
##' \code{\linkS4class{DualEndpointEmax}})) However, is \code{scale} is set to
##' "absolute" then the natural absolute biomarker scale can be used to set a target.
##'
##' @slot target the biomarker target range, that
##' needs to be reached. For example, (0.8, 1.0) and \code{scale="relative"}
##' means we target a dose
##' with at least 80% of maximum biomarker level. As an other example,
##' (0.5, 0.8) would mean that we target a dose between 50% and 80% of
##' the maximum biomarker level.
##' @slot scale either \code{relative} (default, then the \code{target} is interpreted
##' relative to the maximum, so must be a probability range) or \code{absolute}
##' (then the \code{target} is interpreted as absolute biomarker range)
##' @slot overdose the overdose toxicity interval (lower limit excluded, upper
##' limit included)
##' @slot maxOverdoseProb maximum overdose probability that is allowed
##' @slot targetThresh which target probability threshold needs to be fulfilled before the
##' target probability will be used for deriving the next best dose (default: 0.01)
##'
##' @example examples/Rules-class-NextBestDualEndpoint.R
##' @export
##' @keywords classes
.NextBestDualEndpoint <-
setClass(Class="NextBestDualEndpoint",
representation(target="numeric",
scale="character",
overdose="numeric",
maxOverdoseProb="numeric",
targetThresh="numeric"),
prototype(target=c(0.9,1),
scale="relative",
overdose=c(0.35, 1),
maxOverdoseProb=0.25,
targetThresh=0.01),
contains=list("NextBest"),
validity=
function(object){
o <- Validate()
o$check(is.scalar(object@scale) && object@scale %in% c("relative", "absolute"),
"scale must be either 'relative' or 'absolute'")
if(object@scale == "relative")
{
o$check(is.probRange(object@target),
"target has to be a probability range when scale='relative'")
} else {
o$check(is.range(object@target),
"target must be a numeric range")
}
o$check(is.probRange(object@overdose),
"overdose has to be a probability range")
o$check(is.probability(object@maxOverdoseProb),
"maxOverdoseProb has to be a probability")
o$check(is.probability(object@targetThresh),
"targetThresh has to be a probability")
o$result()
})
validObject(.NextBestDualEndpoint())
##' Initialization function for "NextBestDualEndpoint"
##'
##' @param target see \code{\linkS4class{NextBestDualEndpoint}}
##' @param scale see \code{\linkS4class{NextBestDualEndpoint}}
##' @param overdose see \code{\linkS4class{NextBestDualEndpoint}}
##' @param maxOverdoseProb see \code{\linkS4class{NextBestDualEndpoint}}
##' @param targetThresh see \code{\linkS4class{NextBestDualEndpoint}}
##' @return the \code{\linkS4class{NextBestDualEndpoint}} object
##'
##' @export
##' @keywords methods
NextBestDualEndpoint <- function(target,
scale=c("relative", "absolute"),
overdose,
maxOverdoseProb,
targetThresh=0.01)
{
scale <- match.arg(scale)
.NextBestDualEndpoint(target=target,
scale=scale,
overdose=overdose,
maxOverdoseProb=maxOverdoseProb,
targetThresh=targetThresh)
}
## ============================================================
#' Class for Next Best Dose based on Minimum Distance to Target Probability
#'
#' This is typically used for CRM designs where a single target DLT probability
#' is targeted.
#'
#' @slot target target DLT probability.
#'
#' @export
#' @aliases NextBestMinDist
.NextBestMinDist <- setClass(Class = "NextBestMinDist",
contains = "NextBest",
representation(target = "numeric"))
validObject(.NextBestMinDist())
#' @describeIn NextBestMinDist-class Initialization function for `NextBestMinDist`.
#' @param target target DLT probability.
#' @export
NextBestMinDist <- function(target){ .NextBestMinDist(target = target) }
validObject(NextBestMinDist(0.1))
## ============================================================
## --------------------------------------------------
## Virtual class for increments control
## --------------------------------------------------
##' The virtual class for controlling increments
##'
##' @seealso \code{\linkS4class{IncrementsRelative}},
##' \code{\linkS4class{IncrementsRelativeDLT}},
##' \code{\linkS4class{IncrementsRelativeParts}},
##' [`IncrementsNumDoseLevels`]
##' [`IncrementsHSRBeta`]
##'
##' @aliases Increments
##' @export
##' @keywords classes
setClass(Class="Increments",
contains=list("VIRTUAL"))
## --------------------------------------------------
## Increments control based on relative differences in intervals
## --------------------------------------------------
##' Increments control based on relative differences in intervals
##'
##' Note that \code{intervals} is to be read as follows. If for example,
##' we want to specify three intervals: First 0 to less than 50, second at least
##' 50 up to less than 100 mg, and third at least 100 mg, then we specify
##' \code{intervals} to be \code{c(0, 50, 100)}. That means, the right
##' bound of the intervals are exclusive to the interval, and the last interval
##' goes from the last value until infinity.
##'
##' @slot intervals a vector with the left bounds of the relevant intervals
##' @slot increments a vector of the same length with the maximum allowable
##' relative increments in the \code{intervals}
##'
##' @example examples/Rules-class-IncrementsRelative.R
##' @export
##' @keywords classes
.IncrementsRelative <-
setClass(Class="IncrementsRelative",
representation(intervals="numeric",
increments="numeric"),
prototype(intervals=c(0, 2),
increments=c(2, 1)),
contains="Increments",
validity=
function(object){
o <- Validate()
o$check(identical(length(object@increments),
length(object@intervals)),
"increments must have same length as intervals")
o$check(! is.unsorted(object@intervals, strictly=TRUE),
"intervals has to be sorted and have unique values")
o$result()
})
validObject(.IncrementsRelative())
##' Initialization function for "IncrementsRelative"
##'
##' @param intervals see \code{\linkS4class{IncrementsRelative}}
##' @param increments see \code{\linkS4class{IncrementsRelative}}
##' @return the \code{\linkS4class{IncrementsRelative}} object
##'
##' @export
##' @keywords methods
IncrementsRelative <- function(intervals,
increments)
{
.IncrementsRelative(intervals=intervals,
increments=increments)
}
# nolint end
# IncrementsNumDoseLevels-class ----
#' `IncrementsNumDoseLevels`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @slot maxLevels (`count`)\cr corresponding to the number of maximum
#' dose levels to increment for the next dose. It defaults to 1,
#' which means that no dose skipping is allowed - the next dose
#' can be maximum one level higher than the current dose.
#' @slot basisLevel (`string`)\cr corresponding to the dose level used to increment from.
#' It can take two possible values `last` or `max`. If `last` (default)
#' is specified the increments is applied to the last given dose and if
#' `max` is specified the increment is applied from the max given dose
#' level.
#'
#' @example examples/Rules-class-IncrementsNumDoseLevels.R
#' @export
.IncrementsNumDoseLevels <- setClass(
Class = "IncrementsNumDoseLevels",
contains = "Increments",
representation = representation(
maxLevels = "integer",
basisLevel = "character"
),
prototype(
maxLevels = 1L,
basisLevel = "last"
),
validity = validate_increments_numdoselevels
)
# IncrementsNumDoseLevels-constructor ----
#' @rdname IncrementsNumDoseLevels-class
#' @param maxLevels see below.
#' @param basisLevel see below.
#' @export
IncrementsNumDoseLevels <- function(maxLevels=1,
basisLevel="last"){
.IncrementsNumDoseLevels(
maxLevels=safeInteger(maxLevels),
basisLevel=basisLevel
)
}
# IncrementsHSRBeta-class ----
#' `IncrementsHSRBeta`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsHSRBeta`] is a class for limiting further increments using
#' a Hard Safety Rule based on the Bin-Beta model.
#' Increment control is based on the number of observed DLTs and number of
#' subjects at each dose level. The probability of toxicity is calculated
#' using a Bin-Beta model with prior (a,b). If the probability exceeds
#' the threshold for a given dose, that dose and all doses above are excluded
#' from further escalation.
#' This is a hard safety rule that limits further escalation based on the
#' observed data per dose level, independent from the underlying model.
#'
#' @slot target (`proportion`)\cr the target toxicity.
#' @slot prob (`proportion`)\cr the threshold probability for a dose being toxic.
#' @slot a (`number`)\cr shape parameter a>0 of probability
#' distribution Beta (a,b).
#' @slot b (`number`)\cr shape parameter b>0 of probability
#' distribution Beta (a,b).
#'
#' @aliases IncrementsHSRBeta
#' @export
#'
.IncrementsHSRBeta <- setClass(
Class = "IncrementsHSRBeta",
contains = "Increments",
representation(
target = "numeric",
prob = "numeric",
a = "numeric",
b = "numeric"
),
prototype(
target = 0.3,
prob = 0.95,
a = 1,
b = 1
),
validity = validate_increments_hsr_beta
)
# IncrementsHSRBeta-constructor ----
#' @rdname IncrementsHSRBeta-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param a (`number`)\cr see slot definition.
#' @param b (`number`)\cr see slot definition.
#'
#' @example examples/Rules-class-IncrementsHSRBeta.R
#' @export
#'
IncrementsHSRBeta <- function(target = 0.3,
prob = 0.95,
a = 1,
b = 1) {
.IncrementsHSRBeta(
target = target,
prob = prob,
a = a,
b = b
)
}
# nolint start
## --------------------------------------------------
## Increments control based on relative differences in intervals,
## with special rules for part 1 and beginning of part 2
## --------------------------------------------------
##' Increments control based on relative differences in intervals,
##' with special rules for part 1 and beginning of part 2
##'
##' Note that this only works in conjunction with \code{\linkS4class{DataParts}}
##' objects. If the part 2 will just be started in the next cohort, then the
##' next maximum dose will be either \code{dltStart} (e.g. -1) shift of the last
##' part 1 dose in case of a DLT in part 1, or \code{cleanStart} shift (e.g. 0)
##' in case of no DLTs in part 1. If part 1 will still be on in the next cohort,
##' then the next dose level will be the next higher dose level in the
##' \code{part1Ladder} of the data object. If part 2 has been started before,
##' the usual relative increment rules apply, see
##' \code{\linkS4class{IncrementsRelative}}.
##'
##' @slot dltStart integer giving the dose level increment for starting part 2
##' in case of a DLT in part 1
##' @slot cleanStart integer giving the dose level increment for starting part 2
##' in case of a DLT in part 1. If this is less or equal to 0, then the part 1
##' ladder will be used to find the maximum next dose. If this is larger than 0,
##' then the relative increment rules will be applied to find the next maximum
##' dose level.
##'
##' @example examples/Rules-class-IncrementsRelative-DataParts.R
##' @export
##' @keywords classes
.IncrementsRelativeParts <-
setClass(Class="IncrementsRelativeParts",
representation(dltStart="integer",
cleanStart="integer"),
prototype(dltStart=-1L,
cleanStart=1L),
contains="IncrementsRelative",
validity=
function(object){
o <- Validate()
o$check(is.scalar(object@dltStart),
"dltStart must be scalar integer")
o$check(is.scalar(object@cleanStart),
"cleanStart must be scalar integer")
o$check(object@cleanStart >= object@dltStart,
"dltStart cannot be higher than cleanStart")
o$result()
})
validObject(.IncrementsRelativeParts())
##' Initialization function for "IncrementsRelativeParts"
##'
##' @param dltStart see \code{\linkS4class{IncrementsRelativeParts}}
##' @param cleanStart see \code{\linkS4class{IncrementsRelativeParts}}
##' @param \dots additional slots from \code{\linkS4class{IncrementsRelative}}
##' @return the \code{\linkS4class{IncrementsRelativeParts}} object
##'
##' @export
##' @keywords methods
IncrementsRelativeParts <- function(dltStart,
cleanStart,
...)
{
.IncrementsRelativeParts(dltStart=safeInteger(dltStart),
cleanStart=safeInteger(cleanStart),
...)
}
## --------------------------------------------------
## Increments control based on relative differences in terms of DLTs
## --------------------------------------------------
##' Increments control based on relative differences in terms of DLTs
##'
##' Note that \code{DLTintervals} is to be read as follows. If for example,
##' we want to specify three intervals: First 0 DLTs, second 1 or 2 DLTs, and
##' third at least 3 DLTs, then we specify
##' \code{DLTintervals} to be \code{c(0, 1, 3)}. That means, the right
##' bound of the intervals are exclusive to the interval -- the vector only
##' gives the left bounds of the intervals. The last interval goes from 3 to
##' infinity.
##'
##' @slot DLTintervals an integer vector with the left bounds of the relevant
##' DLT intervals
##' @slot increments a vector of the same length with the maximum allowable
##' relative increments in the \code{DLTintervals}
##'
##' @example examples/Rules-class-IncrementsRelativeDLT.R
##' @export
##' @keywords classes
.IncrementsRelativeDLT <-
setClass(Class="IncrementsRelativeDLT",
representation(DLTintervals="integer",
increments="numeric"),
prototype(DLTintervals=as.integer(c(0, 1)),
increments=c(2, 1)),
contains="Increments",
validity=
function(object){
o <- Validate()
o$check(identical(length(object@increments),
length(object@DLTintervals)),
"increments must have same length as DLTintervals")
o$check(! is.unsorted(object@DLTintervals, strictly=TRUE),
"DLTintervals has to be sorted and have unique values")
o$check(all(object@DLTintervals >= 0),
"DLTintervals must only contain non-negative integers")
o$result()
})
validObject(.IncrementsRelativeDLT())
##' Initialization function for "IncrementsRelativeDLT"
##'
##' @param DLTintervals see \code{\linkS4class{IncrementsRelativeDLT}}
##' @param increments see \code{\linkS4class{IncrementsRelativeDLT}}
##' @return the \code{\linkS4class{IncrementsRelativeDLT}} object
##'
##' @export
##' @keywords methods
IncrementsRelativeDLT <- function(DLTintervals,
increments)
{
.IncrementsRelativeDLT(DLTintervals=safeInteger(DLTintervals),
increments=increments)
}
## -----------------------------------------------------------
## Max increment based on minimum of multiple increment rules
## -----------------------------------------------------------
##' Max increment based on minimum of multiple increment rules
##'
##' This class can be used to combine multiple increment rules with the MIN
##' operation.
##'
##' \code{IncrementsList} contains all increment rules, which are again
##' objects of class \code{\linkS4class{Increments}}. The minimum of these
##' individual increments is taken to give the final maximum increment.
##'
##' @slot IncrementsList list of increment rules
##'
##' @example examples/Rules-class-IncrementMin.R
##' @keywords classes
##' @export
.IncrementMin <-
setClass(Class="IncrementMin",
representation(IncrementsList="list"),
prototype(IncrementsList=
list(IncrementsRelativeDLT(DLTintervals=as.integer(c(0, 1)),
increments=c(2, 1)),
IncrementsRelative(intervals=c(0, 2),
increments=c(2, 1)))),
contains="Increments",
validity=
function(object){
o <- Validate()
o$check(all(sapply(object@IncrementsList, is,
"Increments")),
"all IncrementsList elements have to be Increments objects")
o$result()
})
validObject(.IncrementMin())
##' Initialization function for "IncrementMin"
##'
##' @param IncrementsList see \code{\linkS4class{IncrementMin}}
##' @return the \code{\linkS4class{IncrementMin}} object
##'
##' @export
##' @keywords methods
IncrementMin <- function(IncrementsList)
{
.IncrementMin(IncrementsList=IncrementsList)
}
# Stopping-class ----
#' `Stopping`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Stopping`] is a class for for stopping rules.
#'
#' @seealso [`StoppingList`], [`StoppingCohortsNearDose`], [`StoppingPatientsNearDose`],
#' [`StoppingMinCohorts`], [`StoppingMinPatients`], [`StoppingTargetProb`],
#' [`StoppingMTDdistribution`], [`StoppingTargetBiomarker`], [`StoppingHighestDose`]
#' [`StoppingMTDCV`], [`StoppingLowestDoseHSRBeta`].
#'
#' @aliases Stopping
#' @export
#'
setClass(
Class = "Stopping",
contains = list("VIRTUAL")
)
## --------------------------------------------------
## Stopping based on number of cohorts near to next best dose
## --------------------------------------------------
##' Stop based on number of cohorts near to next best dose
##'
##' @slot nCohorts number of required cohorts
##' @slot percentage percentage (between 0 and 100) within the next best dose
##' the cohorts must lie
##'
##' @example examples/Rules-class-StoppingCohortsNearDose.R
##' @keywords classes
##' @export
.StoppingCohortsNearDose <-
setClass(Class="StoppingCohortsNearDose",
representation(nCohorts="integer",
percentage="numeric"),
prototype(nCohorts=2L,
percentage=50),
contains="Stopping",
validity=function(object){
o <- Validate()
o$check((object@nCohorts > 0L) && is.scalar(object@nCohorts),
"nCohorts must be positive scalar")
o$check(is.probability(object@percentage / 100),
"percentage must be between 0 and 100")
o$result()
})
validObject(.StoppingCohortsNearDose())
##' Initialization function for "StoppingCohortsNearDose"
##'
##' @param nCohorts see \code{\linkS4class{StoppingCohortsNearDose}}
##' @param percentage see \code{\linkS4class{StoppingCohortsNearDose}}
##' @return the \code{\linkS4class{StoppingCohortsNearDose}} object
##'
##' @export
##' @keywords methods
StoppingCohortsNearDose <- function(nCohorts,
percentage)
{
.StoppingCohortsNearDose(nCohorts=safeInteger(nCohorts),
percentage=percentage)
}
## --------------------------------------------------
## Stopping based on number of patients near to next best dose
## --------------------------------------------------
##' Stop based on number of patients near to next best dose
##'
##' @slot nPatients number of required patients
##' @slot percentage percentage (between 0 and 100) within the next best dose
##' the patients must lie
##'
##' @example examples/Rules-class-StoppingPatientsNearDose.R
##' @keywords classes
##' @export
.StoppingPatientsNearDose <-
setClass(Class="StoppingPatientsNearDose",
representation(nPatients="integer",
percentage="numeric"),
prototype(nPatients=10L,
percentage=50),
contains="Stopping",
validity=function(object){
o <- Validate()
o$check((object@nPatients > 0L) && is.scalar(object@nPatients),
"nPatients must be positive scalar")
o$check(is.probability(object@percentage / 100),
"percentage must be between 0 and 100")
o$result()
})
validObject(.StoppingPatientsNearDose())
##' Initialization function for "StoppingPatientsNearDose"
##'
##' @param nPatients see \code{\linkS4class{StoppingPatientsNearDose}}
##' @param percentage see \code{\linkS4class{StoppingPatientsNearDose}}
##' @return the \code{\linkS4class{StoppingPatientsNearDose}} object
##'
##' @export
##' @keywords methods
StoppingPatientsNearDose <- function(nPatients,
percentage)
{
.StoppingPatientsNearDose(nPatients=safeInteger(nPatients),
percentage=percentage)
}
## --------------------------------------------------
## Stopping based on minimum number of cohorts
## --------------------------------------------------
##' Stop based on minimum number of cohorts
##'
##' @slot nCohorts minimum required number of cohorts
##'
##' @example examples/Rules-class-StoppingMinCohorts.R
##' @keywords classes
##' @export
.StoppingMinCohorts <-
setClass(Class="StoppingMinCohorts",
representation(nCohorts="integer"),
prototype(nCohorts=3L),
contains="Stopping",
validity=function(object){
o <- Validate()
o$check((object@nCohorts > 0L) && is.scalar(object@nCohorts),
"nCohorts must be positive scalar")
o$result()
})
validObject(.StoppingMinCohorts())
##' Initialization function for "StoppingMinCohorts"
##'
##' @param nCohorts see \code{\linkS4class{StoppingMinCohorts}}
##' @return the \code{\linkS4class{StoppingMinCohorts}} object
##'
##' @export
##' @keywords methods
StoppingMinCohorts <- function(nCohorts)
{
.StoppingMinCohorts(nCohorts=safeInteger(nCohorts))
}
## --------------------------------------------------
## Stopping based on minimum number of patients
## --------------------------------------------------
##' Stop based on minimum number of patients
##'
##' @slot nPatients minimum allowed number of patients
##'
##' @example examples/Rules-class-StoppingMinPatients.R
##' @keywords classes
##' @export
.StoppingMinPatients <-
setClass(Class="StoppingMinPatients",
representation(nPatients="integer"),
prototype(nPatients=20L),
contains="Stopping",
validity=function(object){
o <- Validate()
o$check((object@nPatients > 0L) && is.scalar(object@nPatients),
"nPatients must be positive scalar")
o$result()
})
validObject(.StoppingMinPatients())
##' Initialization function for "StoppingMinPatients"
##'
##' @param nPatients see \code{\linkS4class{StoppingMinPatients}}
##' @return the \code{\linkS4class{StoppingMinPatients}} object
##'
##' @export
##' @keywords methods
StoppingMinPatients <- function(nPatients)
{
.StoppingMinPatients(nPatients=safeInteger(nPatients))
}
## --------------------------------------------------
## Stopping based on probability of target tox interval
## --------------------------------------------------
##' Stop based on probability of target tox interval
##'
##' @slot target the target toxicity interval, e.g. \code{c(0.2, 0.35)}
##' @slot prob required target toxicity probability (e.g. \code{0.4})
##' for reaching sufficient precision
##'
##' @example examples/Rules-class-StoppingTargetProb.R
##' @keywords classes
##' @export
.StoppingTargetProb <-
setClass(Class="StoppingTargetProb",
representation(target="numeric",
prob="numeric"),
prototype(target=c(0.2, 0.35),
prob=0.4),
contains="Stopping",
validity=
function(object){
o <- Validate()
o$check(is.probRange(object@target),
"target must be probability range")
o$check(is.probability(object@prob,
bounds=FALSE),
"prob must be probability > 0 and < 1")
o$result()
})
validObject(.StoppingTargetProb())
##' Initialization function for "StoppingTargetProb"
##'
##' @param target see \code{\linkS4class{StoppingTargetProb}}
##' @param prob see \code{\linkS4class{StoppingTargetProb}}
##' @return the \code{\linkS4class{StoppingTargetProb}} object
##'
##' @export
##' @keywords methods
StoppingTargetProb <- function(target,
prob)
{
.StoppingTargetProb(target=target,
prob=prob)
}
## --------------------------------------------------
## Stopping based on MTD distribution
## --------------------------------------------------
##' Stop based on MTD distribution
##'
##' Has 90% probability above a threshold of 50% of the current
##' MTD been reached? This class is used for this question.
##'
##' @slot target the target toxicity probability (e.g. 0.33) defining the MTD
##' @slot thresh the threshold relative to the MTD (e.g. 0.5)
##' @slot prob required probability (e.g. 0.9)
##'
##' @example examples/Rules-class-StoppingMTDdistribution.R
##' @keywords classes
##' @export
.StoppingMTDdistribution <-
setClass(Class="StoppingMTDdistribution",
representation(target="numeric",
thresh="numeric",
prob="numeric"),
prototype(target=0.33,
thresh=0.5,
prob=0.9),
contains="Stopping",
validity=
function(object){
o <- Validate()
o$check(is.probability(object@target,
bounds=FALSE),
"target must be probability > 0 and < 1")
o$check(is.probability(object@thresh,
bounds=FALSE),
"thresh must be probability > 0 and < 1")
o$check(is.probability(object@prob,
bounds=FALSE),
"prob must be probability > 0 and < 1")
o$result()
})
validObject(.StoppingMTDdistribution())
##' Initialization function for "StoppingMTDdistribution"
##'
##' @param target see \code{\linkS4class{StoppingMTDdistribution}}
##' @param thresh see \code{\linkS4class{StoppingMTDdistribution}}
##' @param prob see \code{\linkS4class{StoppingMTDdistribution}}
##' @return the \code{\linkS4class{StoppingMTDdistribution}} object
##'
##' @export
##' @keywords methods
StoppingMTDdistribution <- function(target,
thresh,
prob)
{
.StoppingMTDdistribution(target=target,
thresh=thresh,
prob=prob)
}
# nolint end
# StoppingMTDCV-class ----
#' `StoppingMTDCV`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingMTDCV`] is a class for stopping rule based on precision of MTD
#' which is calculated as the coefficient of variation (CV) of the MTD.
#'
#' @slot target (`proportion`)\cr toxicity target of MTD.
#' @slot thresh_cv (`number`)\cr threshold for CV to be considered accurate enough
#' to stop the trial.
#'
#' @aliases StoppingMTDCV
#' @export
#'
.StoppingMTDCV <- setClass(
Class = "StoppingMTDCV",
contains = "Stopping",
representation = representation(
target = "numeric",
thresh_cv = "numeric"
),
prototype(
target = 0.3,
thresh_cv = 40
),
validity = validate_stopping_mtd_cv
)
# StoppingMTDCV-constructor ----
#' @rdname StoppingMTDCV-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param thresh_cv (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingMTDCV.R
#'
StoppingMTDCV <- function(target = 0.3,
thresh_cv = 40) {
.StoppingMTDCV(
target = target,
thresh_cv = thresh_cv
)
}
# StoppingLowestDoseHSRBeta-class ----
#' `StoppingLowestDoseHSRBeta`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingLowestDoseHSRBeta`] is a class for stopping based on a Hard Safety
#' Rule using the Beta posterior distribution with Beta(a,b) prior and a
#' Bin-Beta model based on the observed data at the lowest dose level.
#' The rule is triggered when the first dose is considered to be toxic
#' (i.e. above threshold probability) based on the observed data at the
#' lowest dose level and a Beta(a,b) prior distribution.
#' The default prior is Beta(1,1).
#' In case that placebo is used, the rule is evaluated at the second dose of the
#' dose grid, i.e. at the lowest non-placebo dose.
#' Note: this stopping rule is independent from the underlying model.
#'
#' @slot target (`proportion`)\cr the target toxicity.
#' @slot prob (`proportion`)\cr the threshold probability for the lowest
#' dose being toxic.
#' @slot a (`number`)\cr shape parameter a>0 of probability
#' distribution Beta (a,b).
#' @slot b (`number`)\cr shape parameter b>0 of probability
#' distribution Beta (a,b).
#'
#' @aliases StoppingLowestDoseHSRBeta
#' @export
#'
.StoppingLowestDoseHSRBeta <- setClass(
Class = "StoppingLowestDoseHSRBeta",
contains = "Stopping",
representation = representation(
target = "numeric",
prob = "numeric",
a = "numeric",
b = "numeric"
),
prototype(
target = 0.3,
prob = 0.95,
a = 1,
b = 1
),
validity = validate_stopping_lowest_dose_hsr_beta
)
# StoppingLowestDoseHSRBeta-constructor ----
#' @rdname StoppingLowestDoseHSRBeta-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param a (`number`)\cr see slot definition.
#' @param b (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingLowestDoseHSRBeta.R
#'
StoppingLowestDoseHSRBeta <- function(target = 0.3,
prob = 0.95,
a = 1,
b = 1) {
.StoppingLowestDoseHSRBeta(
target = target,
prob = prob,
a = a,
b = b
)
}
# nolint start
## --------------------------------------------------
## Stopping based on probability of target biomarker
## --------------------------------------------------
##' Stop based on probability of target biomarker
##'
##' @slot target the biomarker target range, that
##' needs to be reached. For example, (0.8, 1.0) and \code{scale="relative"}
##' means we target a dose with at least 80% of maximum biomarker level.
##' @slot scale either \code{relative} (default, then the \code{target} is interpreted
##' relative to the maximum, so must be a probability range) or \code{absolute}
##' (then the \code{target} is interpreted as absolute biomarker range)
##' @slot prob required target probability for reaching sufficient precision
##'
##' @example examples/Rules-class-StoppingTargetBiomarker.R
##'
##' @export
.StoppingTargetBiomarker <-
setClass(Class="StoppingTargetBiomarker",
representation(target="numeric",
scale="character",
prob="numeric"),
prototype(target=c(0.9, 1),
scale="relative",
prob=0.3),
contains="Stopping",
validity=
function(object){
o <- Validate()
o$check(is.scalar(object@scale) && object@scale %in% c("relative", "absolute"),
"scale must be either 'relative' or 'absolute'")
if(object@scale == "relative")
{
o$check(is.probRange(object@target),
"target has to be a probability range when scale='relative'")
} else {
o$check(is.range(object@target),
"target must be a numeric range")
}
o$check(is.probability(object@prob,
bounds=FALSE),
"prob must be probability > 0 and < 1")
o$result()
})
validObject(.StoppingTargetBiomarker())
##' Initialization function for `StoppingTargetBiomarker`
##'
##' @param target see \code{\linkS4class{StoppingTargetBiomarker}}
##' @param scale see \code{\linkS4class{StoppingTargetBiomarker}}
##' @param prob see \code{\linkS4class{StoppingTargetBiomarker}}
##' @return the \code{\linkS4class{StoppingTargetBiomarker}} object
##'
##' @export
StoppingTargetBiomarker <- function(target,
scale=c("relative", "absolute"),
prob)
{
scale <- match.arg(scale)
.StoppingTargetBiomarker(target=target,
scale=scale,
prob=prob)
}
## --------------------------------------------------
## Stopping when the highest dose is reached
## --------------------------------------------------
##' Stop when the highest dose is reached
##'
##' @example examples/Rules-class-StoppingHighestDose.R
##' @keywords classes
##' @export
.StoppingHighestDose <-
setClass(Class="StoppingHighestDose",
contains="Stopping")
validObject(.StoppingHighestDose())
##' Initialization function for "StoppingHighestDose"
##'
##' @return the \code{\linkS4class{StoppingHighestDose}} object
##'
##' @export
##' @keywords methods
StoppingHighestDose <- function()
{
.StoppingHighestDose()
}
## --------------------------------------------------
## Stopping based on multiple stopping rules
## --------------------------------------------------
##' Stop based on multiple stopping rules
##'
##' This class can be used to combine multiple stopping rules.
##'
##' \code{stopList} contains all stopping rules, which are again objects of
##' class \code{\linkS4class{Stopping}}, and the \code{summary} is a function
##' taking a logical vector of the size of \code{stopList} and returning a
##' single logical value. For example, if the function \code{all} is given as
##' \code{summary} function, then this means that all stopping rules must be
##' fulfilled in order that the result of this rule is to stop.
##'
##' @slot stopList list of stopping rules
##' @slot summary the summary function to combine the results of the stopping
##' rules into a single result
##'
##' @example examples/Rules-class-StoppingList.R
##' @keywords classes
##' @export
.StoppingList <-
setClass(Class="StoppingList",
representation(stopList="list",
summary="function"),
prototype(stopList=
list(StoppingMinPatients(50),
StoppingMinCohorts(5)),
summary=all),
contains="Stopping",
validity=
function(object){
o <- Validate()
o$check(all(sapply(object@stopList, is, "Stopping")),
"all stopList elements have to Stopping objects")
testRes <- object@summary(rep(c(TRUE, FALSE),
length.out=length(object@stopList)))
o$check(is.bool(testRes),
"summary function must return a boolean value")
o$result()
})
validObject(.StoppingList())
##' Initialization function for "StoppingList"
##'
##' @param stopList see \code{\linkS4class{StoppingList}}
##' @param summary see \code{\linkS4class{StoppingList}}
##' @return the \code{\linkS4class{StoppingList}} object
##'
##' @export
##' @keywords methods
StoppingList <- function(stopList,
summary)
{
.StoppingList(stopList=stopList,
summary=summary)
}
## --------------------------------------------------
## Stopping based on fulfillment of all multiple stopping rules
## --------------------------------------------------
##' Stop based on fulfillment of all multiple stopping rules
##'
##' This class can be used to combine multiple stopping rules with an AND
##' operator.
##'
##' \code{stopList} contains all stopping rules, which are again objects of
##' class \code{\linkS4class{Stopping}}. All stopping rules must be fulfilled in
##' order that the result of this rule is to stop.
##'
##' @slot stopList list of stopping rules
##'
##' @example examples/Rules-class-StoppingAll.R
##' @keywords classes
##' @export
.StoppingAll <-
setClass(Class="StoppingAll",
representation(stopList="list"),
prototype(stopList=
list(StoppingMinPatients(50),
StoppingMinCohorts(5))),
contains="Stopping",
validity=
function(object){
o <- Validate()
o$check(all(sapply(object@stopList, is, "Stopping")),
"all stopList elements have to Stopping objects")
o$result()
})
validObject(.StoppingAll())
##' Initialization function for "StoppingAll"
##'
##' @param stopList see \code{\linkS4class{StoppingAll}}
##' @return the \code{\linkS4class{StoppingAll}} object
##'
##' @export
##' @keywords methods
StoppingAll <- function(stopList)
{
.StoppingAll(stopList=stopList)
}
## --------------------------------------------------
## Stopping based on fulfillment of any stopping rule
## --------------------------------------------------
##' Stop based on fulfillment of any stopping rule
##'
##' This class can be used to combine multiple stopping rules with an OR
##' operator.
##'
##' \code{stopList} contains all stopping rules, which are again objects of
##' class \code{\linkS4class{Stopping}}. Any of these rules must be fulfilled in
##' order that the result of this rule is to stop.
##'
##' @slot stopList list of stopping rules
##'
##' @example examples/Rules-class-StoppingAny.R
##' @keywords classes
##' @export
.StoppingAny <-
setClass(Class="StoppingAny",
representation(stopList="list"),
prototype(stopList=
list(StoppingMinPatients(50),
StoppingMinCohorts(5))),
contains="Stopping",
validity=
function(object){
o <- Validate()
o$check(all(sapply(object@stopList, is, "Stopping")),
"all stopList elements have to Stopping objects")
o$result()
})
validObject(.StoppingAny())
##' Initialization function for "StoppingAny"
##'
##' @param stopList see \code{\linkS4class{StoppingAny}}
##' @return the \code{\linkS4class{StoppingAny}} object
##'
##' @export
##' @keywords methods
StoppingAny <- function(stopList)
{
.StoppingAny(stopList=stopList)
}
##-------------------------------------------------------------------------------------------------------------------
## Stopping based on a target ratio of the 95% credibility interval
## ---------------------------------------------------------------------------------------------------------------
##' Stop based on a target ratio, the ratio of the upper to the lower
##' 95% credibility interval of the estimate of TD end of trial, the dose with probability of DLE equals to the target
##' probability of DLE used at the end of a trial
##' @slot targetRatio the target ratio of the upper to the lower of the 95% credibility interval of the
##' estimate that required to stop a trial
##' @slot targetEndOfTrial the target probability of DLE to be used at the end of a trial
##'
##' @example examples/Rules-class-StoppingTDCIRatio.R
##' @export
##' @keywords classes
.StoppingTDCIRatio <-
setClass(Class="StoppingTDCIRatio",
representation(targetRatio="numeric",
targetEndOfTrial="numeric"),
prototype(targetRatio=5,
targetEndOfTrial=0.3),
contains="Stopping",
validity=
function(object){
o <- Validate()
o$check(is.numeric(object@targetRatio) & object@targetRatio > 0,
"targetRatio must be a positive numerical number")
o$check(is.numeric(object@targetEndOfTrial) & object@targetEndOfTrial >= 0 & object@targetEndOfTrial <= 1,
"targetEndOfTrial must be a numerical number lies between 0 and 1")
o$result()
})
validObject(.StoppingTDCIRatio())
##' Initialization function for "StoppingTDCIRatio"
##'
##' @param targetRatio please refer to \code{\linkS4class{StoppingTDCIRatio}} class object
##' @param targetEndOfTrial please refer to \code{\linkS4class{StoppingTDCIRatio}} class object
##' @return the \code{\linkS4class{StoppingTDCIRatio}} class object
##'
##' @export
##' @keywords methods
StoppingTDCIRatio <- function(targetRatio,
targetEndOfTrial)
{
.StoppingTDCIRatio(targetRatio=targetRatio,
targetEndOfTrial=targetEndOfTrial)
}
## ----------------------------------------------------------------------------------------------------------------
##' Stop based on a target ratio, the ratio of the upper to the lower
##' 95% credibility interval of the estimate of the minimum of the dose which gives the maximum gain (Gstar) and
##' the TD end of trial, the dose with probability of DLE equals to the target
##' probability of DLE used at the end of a trial.
##' @slot targetRatio the target ratio of the upper to the lower of the 95% credibility interval of the
##' estimate that required to stop a trial
##' @slot targetEndOfTrial the target probability of DLE to be used at the end of a trial
##'
##' @example examples/Rules-class-StoppingGstarCIRatio.R
##' @export
##' @keywords classes
.StoppingGstarCIRatio <-
setClass(Class="StoppingGstarCIRatio",
representation(targetRatio="numeric",
targetEndOfTrial="numeric"),
prototype(targetRatio=5,
targetEndOfTrial=0.3),
contains="Stopping",
validity=
function(object){
o <- Validate()
o$check(is.numeric(object@targetRatio) & object@targetRatio > 0,
"targetRatio must be a positive numerical number")
o$check(is.numeric(object@targetEndOfTrial) & object@targetEndOfTrial >= 0 & object@targetEndOfTrial <= 1,
"targetEndOfTrial must be a numerical number lies between 0 and 1")
o$result()
})
validObject(.StoppingGstarCIRatio())
##' Initialization function for "StoppingGstarCIRatio"
##'
##' @param targetRatio please refer to \code{\linkS4class{StoppingGstarCIRatio}} class object
##' @param targetEndOfTrial please refer to \code{\linkS4class{StoppingGstarCIRatio}} class object
##' @return the \code{\linkS4class{StoppingGstarCIRatio}} class object
##'
##' @export
##' @keywords methods
StoppingGstarCIRatio <- function(targetRatio,
targetEndOfTrial)
{
.StoppingGstarCIRatio(targetRatio=targetRatio,
targetEndOfTrial=targetEndOfTrial)
}
## ============================================================
## --------------------------------------------------
## Virtual class for cohort sizes
## --------------------------------------------------
##' The virtual class for cohort sizes
##'
##' @seealso \code{\linkS4class{CohortSizeMax}},
##' \code{\linkS4class{CohortSizeMin}},
##' \code{\linkS4class{CohortSizeRange}},
##' \code{\linkS4class{CohortSizeDLT}},
##' \code{\linkS4class{CohortSizeConst}},
##' \code{\linkS4class{CohortSizeParts}}
##'
##' @export
##' @keywords classes
setClass(Class="CohortSize",
contains=list("VIRTUAL"))
## --------------------------------------------------
## Cohort size based on dose range
## --------------------------------------------------
##' Cohort size based on dose range
##'
##' @slot intervals a vector with the left bounds of the relevant dose intervals
##' @slot cohortSize an integer vector of the same length with the cohort
##' sizes in the \code{intervals}
##'
##' @example examples/Rules-class-CohortSizeRange.R
##' @export
##' @keywords classes
.CohortSizeRange <-
setClass(Class="CohortSizeRange",
representation(intervals="numeric",
cohortSize="integer"),
prototype(intervals=c(0, 20),
cohortSize=as.integer(c(1L, 3L))),
contains="CohortSize",
validity=
function(object){
o <- Validate()
o$check(identical(length(object@cohortSize),
length(object@intervals)),
"cohortSize must have same length as intervals")
o$check(all(object@cohortSize >= 0),
"cohortSize must only contain positive integers")
o$check(! is.unsorted(object@intervals, strictly=TRUE),
"intervals has to be sorted and have unique values")
o$result()
})
validObject(.CohortSizeRange())
##' Initialization function for "CohortSizeRange"
##'
##' @param intervals see \code{\linkS4class{CohortSizeRange}}
##' @param cohortSize see \code{\linkS4class{CohortSizeRange}}
##' @return the \code{\linkS4class{CohortSizeRange}} object
##'
##' @export
##' @keywords methods
CohortSizeRange <- function(intervals,
cohortSize)
{
.CohortSizeRange(intervals=intervals,
cohortSize=safeInteger(cohortSize))
}
## --------------------------------------------------
## Cohort size based on number of DLTs
## --------------------------------------------------
##' Cohort size based on number of DLTs
##'
##' @slot DLTintervals an integer vector with the left bounds of the relevant
##' DLT intervals
##' @slot cohortSize an integer vector of the same length with the cohort
##' sizes in the \code{DLTintervals}
##'
##' @example examples/Rules-class-CohortSizeDLT.R
##' @export
##' @keywords classes
.CohortSizeDLT <-
setClass(Class="CohortSizeDLT",
representation(DLTintervals="integer",
cohortSize="integer"),
prototype(DLTintervals=as.integer(c(0, 1)),
cohortSize=as.integer(c(1, 3))),
contains="CohortSize",
validity=
function(object){
o <- Validate()
o$check(identical(length(object@cohortSize),
length(object@DLTintervals)),
"cohortSize must have same length as DLTintervals")
o$check(all(object@cohortSize >= 0),
"cohortSize must only contain positive integers")
o$check(! is.unsorted(object@DLTintervals, strictly=TRUE),
"DLTintervals has to be sorted and have unique values")
o$check(all(object@DLTintervals >= 0),
"DLTintervals must only contain non-negative integers")
o$result()
})
validObject(.CohortSizeDLT())
##' Initialization function for "CohortSizeDLT"
##'
##' @param DLTintervals see \code{\linkS4class{CohortSizeDLT}}
##' @param cohortSize see \code{\linkS4class{CohortSizeDLT}}
##' @return the \code{\linkS4class{CohortSizeDLT}} object
##'
##' @export
##' @keywords methods
CohortSizeDLT <- function(DLTintervals,
cohortSize)
{
.CohortSizeDLT(DLTintervals=safeInteger(DLTintervals),
cohortSize=safeInteger(cohortSize))
}
## --------------------------------------------------
## Constant cohort size
## --------------------------------------------------
##' Constant cohort size
##'
##' This class is used when the cohort size should be kept constant.
##'
##' @slot size the constant integer size
##'
##' @example examples/Rules-class-CohortSizeConst.R
##' @keywords classes
##' @export
.CohortSizeConst <-
setClass(Class="CohortSizeConst",
representation(size="integer"),
prototype(size=3L),
contains="CohortSize",
validity=
function(object){
o <- Validate()
o$check(is.scalar(object@size) && (object@size >= 0),
"size needs to be positive scalar")
o$result()
})
validObject(.CohortSizeConst())
##' Initialization function for "CohortSizeConst"
##'
##' @param size see \code{\linkS4class{CohortSizeConst}}
##' @return the \code{\linkS4class{CohortSizeConst}} object
##'
##' @export
##' @keywords methods
CohortSizeConst <- function(size)
{
.CohortSizeConst(size=safeInteger(size))
}
## --------------------------------------------------
## Cohort size based on the parts
## --------------------------------------------------
##' Cohort size based on the parts
##'
##' This class is used when the cohort size should change for the second part of
##' the dose escalation. Only works in conjunction with
##' \code{\linkS4class{DataParts}} objects.
##'
##' @slot sizes the two sizes for part 1 and part 2
##'
##' @keywords classes
##' @example examples/Rules-class-CohortSizeParts.R
##' @export
.CohortSizeParts <-
setClass(Class="CohortSizeParts",
representation(sizes="integer"),
prototype(sizes=as.integer(c(1, 3))),
contains="CohortSize",
validity=
function(object){
o <- Validate()
o$check(all(object@sizes > 0),
"the cohort sizes need to be positive")
o$check(identical(length(object@sizes), 2L),
"2 elements required in sizes")
o$result()
})
validObject(.CohortSizeParts())
##' Initialization function for "CohortSizeParts"
##'
##' @param sizes see \code{\linkS4class{CohortSizeParts}}
##' @return the \code{\linkS4class{CohortSizeParts}} object
##' @export
##'
##' @keywords methods
CohortSizeParts <- function(sizes)
{
.CohortSizeParts(sizes=safeInteger(sizes))
}
## --------------------------------------------------
## Size based on maximum of multiple cohort size rules
## --------------------------------------------------
##' Size based on maximum of multiple cohort size rules
##'
##' This class can be used to combine multiple cohort size rules with the MAX
##' operation.
##'
##' \code{cohortSizeList} contains all cohort size rules, which are again
##' objects of class \code{\linkS4class{CohortSize}}. The maximum of these
##' individual cohort sizes is taken to give the final cohort size.
##'
##' @slot cohortSizeList list of cohort size rules
##'
##' @example examples/Rules-class-CohortSizeMax.R
##' @keywords classes
##' @export
.CohortSizeMax <-
setClass(Class="CohortSizeMax",
representation(cohortSizeList="list"),
prototype(cohortSizeList=
list(CohortSizeRange(intervals=c(0, 30),
cohortSize=c(1, 3)),
CohortSizeDLT(DLTintervals=c(0, 1),
cohortSize=c(1, 3)))),
contains="CohortSize",
validity=
function(object){
o <- Validate()
o$check(all(sapply(object@cohortSizeList, is,
"CohortSize")),
"all cohortSizeList elements have to be CohortSize objects")
o$result()
})
validObject(.CohortSizeMax())
##' Initialization function for "CohortSizeMax"
##'
##' @param cohortSizeList see \code{\linkS4class{CohortSizeMax}}
##' @return the \code{\linkS4class{CohortSizeMax}} object
##'
##' @export
##' @keywords methods
CohortSizeMax <- function(cohortSizeList)
{
.CohortSizeMax(cohortSizeList=cohortSizeList)
}
## --------------------------------------------------
## Size based on minimum of multiple cohort size rules
## --------------------------------------------------
##' Size based on minimum of multiple cohort size rules
##'
##' This class can be used to combine multiple cohort size rules with the MIN
##' operation.
##'
##' \code{cohortSizeList} contains all cohort size rules, which are again
##' objects of class \code{\linkS4class{CohortSize}}. The minimum of these
##' individual cohort sizes is taken to give the final cohort size.
##'
##' @slot cohortSizeList list of cohort size rules
##'
##' @example examples/Rules-class-CohortSizeMin.R
##' @keywords classes
##' @export
.CohortSizeMin <-
setClass(Class="CohortSizeMin",
representation(cohortSizeList="list"),
prototype(cohortSizeList=
list(CohortSizeRange(intervals=c(0, 30),
cohortSize=c(1, 3)),
CohortSizeDLT(DLTintervals=c(0, 1),
cohortSize=c(1, 3)))),
contains="CohortSize",
validity=
function(object){
o <- Validate()
o$check(all(sapply(object@cohortSizeList, is,
"CohortSize")),
"all cohortSizeList elements have to be CohortSize objects")
o$result()
})
validObject(.CohortSizeMin())
##' Initialization function for "CohortSizeMin"
##'
##' @param cohortSizeList see \code{\linkS4class{CohortSizeMin}}
##' @return the \code{\linkS4class{CohortSizeMin}} object
##'
##' @export
##' @keywords methods
CohortSizeMin <- function(cohortSizeList)
{
.CohortSizeMin(cohortSizeList=cohortSizeList)
}
## ==========================================================================================
## ------------------------------------------------------------------------------------
## Class for next best based on Pseudo DLE Model with samples
## -----------------------------------------------------------------------------------------
##' Next best dose based on Pseudo DLE Model with samples
##'
##' The class is to find the next best dose for allocation and the dose for final recommendation
##' at the end of a trial. There are two input target probabilities of the occurrence of a DLE
##' used during trial and used at the end of trial to find the two doses. For this class, only
##' DLE response will be incorporated for the dose allocation and DLEsamples
##' must be used to obtain the next dose for allocation.
##'
##' @slot targetDuringTrial the target probability of the occurrence of a DLE to be used
##' during the trial
##' @slot targetEndOfTrial the target probability of the occurrence of a DLE to be used at the end
##' of the trial. This target is particularly used to recommend the dose at the end of a trial
##' for which its posterior
##' probability of the occurrence of a DLE is equal to this target
##' @slot derive the function which derives from the input, a vector of the posterior samples called
##' \code{TDsamples} of the dose
##' which has the probability of the occurrence of DLE equals to either the targetDuringTrial or
##' targetEndOfTrial, the final next best TDtargetDuringTrial (the dose with probability of the
##' occurrence of DLE equals to the targetDuringTrial)and TDtargetEndOfTrial estimate.
##'
##' @example examples/Rules-class-NextBestTDsamples.R
##' @export
##' @keywords class
.NextBestTDsamples<-
setClass(Class="NextBestTDsamples",
representation(targetDuringTrial="numeric",
targetEndOfTrial="numeric",
derive="function"),
##targetDuringTrial is the target DLE probability during the trial
##targetEndOfTrial is the target DLE probability at the End of the trial
prototype(targetDuringTrial=0.35,
targetEndOfTrial=0.3,
derive=function(TDsamples){
quantile(TDsamples,prob=0.3)}),
contains=list("NextBest"),
validity=
function(object){
o<-Validate()
o$check(is.probability(object@targetDuringTrial,
bounds=FALSE),
"targetDuringTrial must be probability > 0 and < 1")
o$check(is.probability(object@targetEndOfTrial,
bounds=FALSE),
"targetEndOfTrial must be probability > 0 and < 1")
o$check(identical(names(formals(object@derive)),
c("TDsamples")),"derive must have as single argument 'TDsamples'")
o$result()
})
validObject(.NextBestTDsamples())
## ---------------------------------------------------------------------------
##' Initialization function for class "NextBestTDsamples"
##'
##' @param targetDuringTrial please refer to \code{\linkS4class{NextBestTDsamples}} class object
##' @param targetEndOfTrial please refer to \code{\linkS4class{NextBestTDsamples}} class object
##' @param derive please refer to \code{\linkS4class{NextBestTDsamples}} class object
##' @return the \code{\linkS4class{NextBestTDsamples}} class object
##'
##' @export
##' @keywords methods
NextBestTDsamples<- function(targetDuringTrial,targetEndOfTrial,derive)
{
.NextBestTDsamples(targetDuringTrial=targetDuringTrial,
targetEndOfTrial=targetEndOfTrial,
derive=derive)
}
## ------------------------------------------------------------------------------
## class for nextBest based on Pseudo DLE model without sample
## -----------------------------------------------------------------------------
##' Next best dose based on Pseudo DLE model without sample
##'
##' The class is to find the next best dose for allocation and the dose for final recommendation
##' at the end of a trial without involving any samples. This is a class for which only
##' DLE response will be incorporated for the dose-allocation.
##' This is only based on the probabilities of
##' the occurrence of a DLE obtained by using the modal estimates of the model paramters.
##' There are two inputs inputs which are the two target
##' probabilities of the occurrence of a DLE used during trial
##' and used at the end of trial, for finding the next best dose for allocation and the dose
##' for recommendation at the end of the trial.
##' It is only suitable to use with the model specified in \code{ModelTox} class.
##'
##' @slot targetDuringTrial the target probability of the occurrence of a DLE to be used
##' during the trial
##' @slot targetEndOfTrial the target probability of the occurrence of a DLE to be used at the end
##' of the trial. This target is particularly used to recommend the dose for which its posterior
##' probability of the occurrence of a DLE is equal to this target
##'
##' @example examples/Rules-class-NextBestTD.R
##' @export
##' @keywords class
.NextBestTD<-
setClass(Class="NextBestTD",
representation(targetDuringTrial="numeric",
targetEndOfTrial="numeric"),
##targetDuringTrial is the target DLE probability during the trial
##targetEndOfTrial is the target DLE probability at the End of the trial
prototype(targetDuringTrial=0.35,
targetEndOfTrial=0.3),
contains=list("NextBest"),
validity=
function(object){
o<-Validate()
o$check(is.probability(object@targetDuringTrial,
bounds=FALSE),
"targetDuringTrial must be probability > 0 and < 1")
o$check(is.probability(object@targetEndOfTrial,
bounds=FALSE),
"targetEndOfTrial must be probability > 0 and < 1")
o$result()
})
validObject(.NextBestTD())
##' Initialization function for the class "NextBestTD"
##'
##' @param targetDuringTrial please refer to \code{\linkS4class{NextBestTD}} class object
##' @param targetEndOfTrial please refer to \code{\linkS4class{NextBestTD}} class object
##' @return the \code{\linkS4class{NextBestTD}} class object
##'
##' @export
##' @keywords methods
NextBestTD <- function(targetDuringTrial,targetEndOfTrial)
{
.NextBestTD(targetDuringTrial=targetDuringTrial,
targetEndOfTrial=targetEndOfTrial)
}
##------------------------------------------------------------------------------------------------------
## Class for next best with maximum gain value based on a pseudo DLE and efficacy model without samples
## ----------------------------------------------------------------------------------------------------
##' Next best dose with maximum gain value based on a pseudo DLE and efficacy model without samples
##'
##' This is a class for which to find the next dose which is safe and give the maximum gain value
##' for allocation. This is a class where no DLE and efficacy samples are involved. This is only based
##' on the probabilities of the occurrence of a DLE and the values of the mean efficacy responses
##' obtained by using the modal estimates of the DLE and efficacy model parameters.
##' There are two inputs which are the two target
##' probabilities of the occurrence of a DLE used during trial
##' and used at the end of trial, for finding the next best dose that is safe and gives the maximum
##' gain value and the dose to recommend at the end of a trial. This is only suitable to use with DLE models
##' specified in 'ModelTox' class and efficacy models specified in 'ModelEff' (except 'EffFlexi' model)
##' class
##'
##' @slot DLEDuringTrialtarget the target probability of the occurrence of a DLE to be used
##' during the trial
##' @slot DLEEndOfTrialtarget the target probability of the occurrence of a DLE to be used at the end
##' of the trial. This target is particularly used to recommend the dose for which its posterior
##' probability of the occurrence of a DLE is equal to this target
##'
##' @example examples/Rules-class-NextBestMaxGain.R
##' @export
##' @keywords class
.NextBestMaxGain<-
setClass(Class="NextBestMaxGain",
representation(DLEDuringTrialtarget="numeric",
DLEEndOfTrialtarget="numeric"),
prototype(DLEDuringTrialtarget=0.35,
DLEEndOfTrialtarget=0.3),
contains=list("NextBest"),
validity=
function(object){
o <- Validate()
o$check(is.probability(object@DLEDuringTrialtarget),
"DLE DuringTrialtarget has to be a probability")
o$check(is.probability(object@DLEEndOfTrialtarget),
"DLE EndOfTrialtarget has to be a probability")
o$result()
})
validObject(.NextBestMaxGain())
##' Initialization function for the class 'NextBestMaxGain'
##'
##' @param DLEDuringTrialtarget please refer to \code{\linkS4class{NextBestMaxGain}} class object
##' @param DLEEndOfTrialtarget please refer to \code{\linkS4class{NextBestMaxGain}} class object
##' @return the \code{\linkS4class{NextBestMaxGain}} class object
##'
##' @export
##' @keywords methods
NextBestMaxGain <- function(DLEDuringTrialtarget,
DLEEndOfTrialtarget)
{.NextBestMaxGain(DLEDuringTrialtarget=DLEDuringTrialtarget,
DLEEndOfTrialtarget=DLEEndOfTrialtarget)}
##------------------------------------------------------------------------------------------------------
## Class for next best with maximum gain value based on a pseudo DLE and efficacy model with samples
## ----------------------------------------------------------------------------------------------------
##' Next best dose with maximum gain value based on a pseudo DLE and efficacy model with samples
##'
##' This is a class for which to find the next dose which is safe and give the maximum gain value
##' for allocation. This is a class where DLE and efficacy samples are involved.
##' There are two inputs which are the two target
##' probabilities of the occurrence of a DLE used during trial
##' and used at the end of trial, for finding the next best dose that is safe and gives the maximum
##' gain value and the dose to recommend at the end of a trial. This is only suitable to use with DLE models
##' specified in 'ModelTox' class and efficacy models specified in 'ModelEff' class
##' class
##'
##' @slot DLEDuringTrialtarget the target probability of the occurrence of a DLE to be used
##' during the trial
##' @slot DLEEndOfTrialtarget the target probability of the occurrence of a DLE to be used at the end
##' of the trial. This target is particularly used to recommend the dose for which its posterior
##' probability of the occurrence of a DLE is equal to this target
##' @slot TDderive the function which derives from the input, a vector of the posterior samples called
##' \code{TDsamples} of the dose
##' which has the probability of the occurrence of DLE equals to either the targetDuringTrial or
##' targetEndOfTrial, the final next best TDtargetDuringTrial (the dose with probability of the
##' occurrence of DLE equals to the targetDuringTrial)and TDtargetEndOfTrial estimate.
##' @slot Gstarderive the function which derives from the input, a vector of the posterior Gstar (the dose
##' which gives the maximum gain value) samples
##' called \code{Gstarsamples}, the final next best Gstar estimate.
##'
##' @example examples/Rules-class-NextBestMaxGainSamples.R
##'
##' @export
##' @keywords class
.NextBestMaxGainSamples<-
setClass(Class="NextBestMaxGainSamples",
representation(DLEDuringTrialtarget="numeric",
DLEEndOfTrialtarget="numeric",
TDderive="function",
Gstarderive="function"),
prototype(DLEDuringTrialtarget=0.35,
DLEEndOfTrialtarget=0.3,
TDderive=function(TDsamples){
quantile(TDsamples,prob=0.3)},
Gstarderive=function(Gstarsamples){
quantile(Gstarsamples,prob=0.5)}),
contains=list("NextBest"),
validity=
function(object){
o <- Validate()
o$check(is.probability(object@DLEDuringTrialtarget),
"DLE DuringTrialtarget has to be a probability")
o$check(is.probability(object@DLEEndOfTrialtarget),
"DLE EndOfTrialtarget has to be a probability")
o$check(identical(names(formals(object@TDderive)),
c("TDsamples")),"derive must have as single argument 'TDsamples'")
o$check(identical(names(formals(object@Gstarderive)),
c("Gstarsamples")),"derive must have as single argument 'Gstarsamples'")
o$result()
})
validObject(.NextBestMaxGainSamples)
##' Initialization function for class "NextBestMaxGainSamples"
##'
##' @param DLEDuringTrialtarget please refer to \code{\linkS4class{NextBestMaxGainSamples}} class object
##' @param DLEEndOfTrialtarget please refer to \code{\linkS4class{NextBestMaxGainSamples}} class object
##' @param TDderive please refer to \code{\linkS4class{NextBestMaxGainSamples}} class object
##' @param Gstarderive please refer to \code{\linkS4class{NextBestMaxGainSamples}} class object
##'
##' @return the \code{\linkS4class{NextBestMaxGainSamples}} class object
##'
##' @export
##' @keywords methods
NextBestMaxGainSamples <- function(DLEDuringTrialtarget,
DLEEndOfTrialtarget,TDderive,Gstarderive)
{.NextBestMaxGainSamples(DLEDuringTrialtarget=DLEDuringTrialtarget,
DLEEndOfTrialtarget=DLEEndOfTrialtarget,
TDderive=TDderive,
Gstarderive=Gstarderive)
}
## ============================================================
## --------------------------------------------------
## Virtual class for safety window
## --------------------------------------------------
##' The virtual class for safety window
##'
##' @seealso \code{\linkS4class{SafetyWindowSize}},
##' \code{\linkS4class{SafetyWindowConst}},
##'
##' @export
##' @keywords classes
setClass(Class="SafetyWindow",
contains=list("VIRTUAL"))
## ============================================================
## --------------------------------------------------
## Safety window length based on cohort size
## --------------------------------------------------
##' Safety window length based on cohort size.
##' This class is used to decide the rolling rule from the clinical perspective.
##'
##' \code{patientGap} is to be used as follows. If for example, the
##' cohort size is 4 and we want to specify three time intervals between these
##' four patients: The interval between the 1st and 2nd patient = 7 units of time
##' , the interval between the 2nd and 3rd patient = 5 units of time, the interval
##' between the 3rd and 4th patient = 3 units of time, then we specify
##' \code{patientGap} to be \code{c(7,5,3)}. Sometimes, we only think the interval
##' between the 1st and 2nd patient should be increased for the safety consideration
##' , and the rest time intervals can be the same, whatever the cohort size is, then
##' we specify \code{patientGap} to be \code{c(7,3)}. The package will automatically
##' repeat the last element of the vector for the rest time intervals.
##'
##' Note that \code{sizeIntervals} is to be read as follows. For instance, When we
##' want to change the `patientGap` based on the cohort size, i.e. the time interval
##' between the 1st and 2nd patient = 9 units of time and the rest time intervals are
##' 5 units of time when the cohort size is equal or larger than 4. And the time
##' interval between the 1st and 2nd patient = 7 units of time and the rest time
##' intervals are 3 units of time when the cohort size is smaller than 4, then we
##' specify \code{sizeIntervals} to be \code{c(0, 4)}. That means, the right
##' bound of the intervals are exclusive to the interval, and the last interval
##' goes from the last value until infinity.
##'
##' @slot patientGap Observed period of the previous patient before the next patient
##' can be dosed
##' @slot sizeIntervals An integer vector with the left bounds of the relevant
##' cohort size intervals
##' @slot patientFollow The period of time that each patient in the cohort needs to be
##' followed before the next cohort open
##' @slot patientFollowMin At least one patient in the cohort needs to be followed at
##' the minimal follow up time
##'
##' @example examples/Rules-class-SafetyWindowSize.R
##' @export
##' @keywords classes
.SafetyWindowSize <-
setClass(Class="SafetyWindowSize",
representation(patientGap="list",
sizeIntervals="numeric",
patientFollow="numeric",
patientFollowMin="numeric"),
prototype(patientGap=list(0),
sizeIntervals=as.integer(c(1L,3L)),
patientFollow=1,
patientFollowMin=1),
contains="SafetyWindow",
validity=
function(object){
o <- Validate()
o$check(all(sapply(object@patientGap,function(x){x>=0})),
"patientGap should be non-negative number")
o$check(all(object@sizeIntervals > 0),
"sizeIntervals must only contain positive integers")
o$check(all(object@patientFollow > 0),
"patientFollow should be positive number")
o$check(all(object@patientFollowMin > 0),
"patientFollowMin should be positive number")
o$result()
})
validObject(.SafetyWindowSize())
##' Initialization function for `SafetyWindowSize`
##'
##' @param patientGap see \code{\linkS4class{SafetyWindowSize}}
##' @param sizeIntervals see \code{\linkS4class{SafetyWindowSize}}
##' @param patientFollow see \code{\linkS4class{SafetyWindowSize}}
##' @param patientFollowMin see \code{\linkS4class{SafetyWindowSize}}
##'
##' @return the \code{\linkS4class{SafetyWindowSize}} object
##'
##' @export
##' @keywords methods
SafetyWindowSize <- function(patientGap,
sizeIntervals,
patientFollow,
patientFollowMin)
{
if(patientFollow > patientFollowMin)
{
warning("the value of patientFollowMin is typically larger than the value of patientFollow")
}
.SafetyWindowSize(patientGap=patientGap,
sizeIntervals=sizeIntervals,
patientFollow=patientFollow,
patientFollowMin=patientFollowMin)
}
## ============================================================
## --------------------------------------------------
## Constant safety window length
## --------------------------------------------------
##' Constant safety window length
##'
##' This class is used when the `patientGap` should be kept constant.
##'
##' @slot patientGap the constant gap between patients.
##' @slot patientFollow how long to follow each patient.
##' @slot patientFollowMin minimum follow up.
##'
##' @example examples/Rules-class-SafetyWindowConst.R
##' @keywords classes
##' @export
.SafetyWindowConst <-
setClass(Class="SafetyWindowConst",
representation(patientGap="numeric",
patientFollow="numeric",
patientFollowMin="numeric"),
prototype(patientGap=0,
patientFollow=1,
patientFollowMin=1),
contains="SafetyWindow",
validity=
function(object){
o <- Validate()
o$check(all(object@patientGap >= 0),
"patientGap should be non-negative number")
o$check(all(object@patientFollow > 0),
"patientFollow should be positive number")
o$check(all(object@patientFollowMin > 0),
"patientFollowMin should be positive number")
o$result()
})
validObject(.SafetyWindowConst())
##' Initialization function for `SafetyWindowConst`
##'
##' @param patientGap see \code{\linkS4class{SafetyWindowConst}}
##' @param patientFollow see \code{\linkS4class{SafetyWindowConst}}
##' @param patientFollowMin see \code{\linkS4class{SafetyWindowConst}}
##'
##' @return the \code{\linkS4class{SafetyWindowConst}} object
##'
##' @export
##' @keywords methods
SafetyWindowConst <- function(patientGap,
patientFollow,
patientFollowMin)
{
if(patientFollow > patientFollowMin)
{
warning("the value of patientFollowMin is typically larger than the value of patientFollow")
}
.SafetyWindowConst(patientGap=patientGap,
patientFollow=patientFollow,
patientFollowMin=patientFollowMin)
}
## ============================================================
# nolint end
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.