bayer/R_DK/crmpack_R_programs_amended/ZZ_Rules-class_DK.R
In 0liver0815/onc-crmpack-test: Object-Oriented Implementation of CRM Designs
#####################################################################################
## Author: Daniel Sabanes Bove [sabanesd *a*t* roche *.* com]
## Wai Yin Yeung [ w *.* yeung1 *a*t* lancaster *.* ac *.* uk]
## Project: Object-oriented implementation of CRM designs
##
## Time-stamp: <[Rules-class.R] by DSB Die 09/06/2015 21:28>
##
## Description:
## Encapsulate the rules in formal classes.
##
## History:
## 07/02/2014 file creation
## 10/07/2014 Added further rule classs
###################################################################################
##' @include helpers.R
{}
## ============================================================
## --------------------------------------------------
## 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}},
##' \code{\linkS4class{NextBestMTDCRM}}
##'
##' @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)
}
## ------------------------------------------------------
## Next best dose based on CRM MTD allocation probability
## ------------------------------------------------------
##' The class with the input for finding the next best dose based on CRM MTD
##' allocation probability.
##'
##' @slot target the target toxicity probability
##' @slot pbomethod the method used to handle the allocation probability for the
##' zero dose. Applicable to cases where data@plabebo = "FALSE"
##' If \code{none}, then the number of simulation instances allocated to zero
##' dose, are exuded from the derivation of allocation probabilities.
##' If \code{min}, then the number of simulation instances allocated to zero
##' dose, are combined with the instances allocated to the minimum planned dose.
##' If \code{max}, then the number of simulation instances allocated to zero
##' dose, are combined with the instances allocated to the maximum planned dose.
##'
##' @export
##' @keywords classes
.NextBestMTDCRM <-
setClass(Class="NextBestMTDCRM",
representation(target="numeric",
pbomethod="character"),
prototype(target=0.3,
pbomethod="none"),
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(is.scalar(object@pbomethod) && object@pbomethod %in% c("none", "min", "max"),
"pbomethod must be either 'none' or 'min' or 'max'")
o$result()
})
validObject(.NextBestMTDCRM())
##' Initialization function for class "NextBestMTDCRM"
##'
##' @param target see \code{\linkS4class{NextBestMTDCRM}}
##' @param pbomethod see \code{\linkS4class{NextBestMTDCRM}}
##' @return the \code{\linkS4class{NextBestMTDCRM}} object
##'
##' @export
##' @keywords methods
NextBestMTDCRM <- function(target,
pbomethod=c("none", "min" , "max"))
{
pbomethod <- match.arg(pbomethod)
.NextBestMTDCRM(target=target,
pbomethod=pbomethod)
}
## ============================================================
## --------------------------------------------------
## Virtual class for increments control
## --------------------------------------------------
##' The virtual class for controlling increments
##'
##' @seealso \code{\linkS4class{IncrementsRelative}},
##' \code{\linkS4class{IncrementsRelativeDLT}},
##' \code{\linkS4class{IncrementsRelativeParts}},
##' \code{\linkS4class{IncrementsHSRBeta}},
##' \code{\linkS4class{IncrementsNumDoseLevelsMaxTested}}
##'
##' @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)
}
## --------------------------------------------------
## Increments control based on number of dose levels
## --------------------------------------------------
##' Increments control based on number of dose levels
##'
##' @slot maxLevels scalar positive integer for 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.
##'
##' @example examples/Rules-class-IncrementsNumDoseLevels.R
##' @export
##' @keywords classes
.IncrementsNumDoseLevels <-
setClass(Class="IncrementsNumDoseLevels",
representation(maxLevels="integer"),
prototype(maxLevels=1L),
contains="Increments",
validity=
function(object){
o <- Validate()
o$check(is.scalar(object@maxLevels) &&
is.integer(object@maxLevels) &&
object@maxLevels > 0,
"maxLevels must be scalar positive integer")
o$result()
})
validObject(.IncrementsNumDoseLevels())
##' Initialization function for "IncrementsNumDoseLevels"
##'
##' @param maxLevels see \code{\linkS4class{IncrementsNumDoseLevels}}
##' @return the \code{\linkS4class{IncrementsNumDoseLevels}} object
##'
##' @export
##' @keywords methods
IncrementsNumDoseLevels <- function(maxLevels=1)
{
.IncrementsNumDoseLevels(maxLevels=safeInteger(maxLevels))
}
## --------------------------------------------------
## 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)
}
## -------------------------------------------------------
## Increments control based on Hard Safety Rule - Beta(a,b)
## -------------------------------------------------------
##' Increments control based on eligable dose levels according to Hard Safety
##' Rule - Beta(a,b)
##'
##' @slot target a probability > 0 and < 1 of the target toxicity rate
##' @slot prob a probability > 0 and < 1 of the confidence of the test
##' @slot a positive real number representing the shape parameter of a Beta(a,b) distribution
##' @slot b positive real number representing the shape parameter of a Beta(a,b) distribution
##'
##' @export
##' @keywords classes
.IncrementsHSRBeta <-
setClass(Class="IncrementsHSRBeta",
representation(target="numeric",
prob="numeric",
a="numeric",
b="numeric"),
prototype(target=0.3,
prob=0.9,
a=1,
b=1),
contains="Increments",
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@prob,bounds=FALSE),
"prob must be probability > 0 and < 1")
o$check(is.numeric(object@a) & object@a > 0,
"Beta distribution shape parameter a must me a real number > 0")
o$check(is.numeric(object@b) & object@b > 0,
"Beta distribution shape parameter b must me a real number > 0")
o$result()
})
validObject(.IncrementsHSRBeta())
##' Initialization function for "IncrementsHSRBeta"
##'
##' @param target see \code{\linkS4class{IncrementsHSRBeta}}
##' @param prob see \code{\linkS4class{IncrementsHSRBeta}}
##' @param a see \code{\linkS4class{IncrementsHSRBeta}}
##' @param b see \code{\linkS4class{IncrementsHSRBeta}}
##'
##' @return the \code{\linkS4class{IncrementsHSRBeta}} object
##'
##' @export
##' @keywords methods
IncrementsHSRBeta <- function(target,prob,a,b)
{
.IncrementsHSRBeta(target=target,
prob=prob,
a=a,
b=b)
}
## -----------------------------------------------------------------------------------------
## Increments control based on number of dose levels relative to the max dose tested so far
## -----------------------------------------------------------------------------------------
##' Increments control based on number of dose levels relative to the max dose tested so far
##'
##' @slot maxLevels scalar positive integer for 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 max dose tested so far.
##'
##' @export
##' @keywords classes
.IncrementsNumDoseLevelsMaxTested <-
setClass(Class="IncrementsNumDoseLevelsMaxTested",
representation(maxLevels="integer"),
prototype(maxLevels=1L),
contains="Increments",
validity=
function(object){
o <- Validate()
o$check(is.scalar(object@maxLevels) &&
is.integer(object@maxLevels) &&
object@maxLevels > 0,
"maxLevels must be scalar positive integer")
o$result()
})
validObject(.IncrementsNumDoseLevelsMaxTested())
##' Initialization function for "IncrementsNumDoseLevelsMaxTested"
##'
##' @param maxLevels see \code{\linkS4class{IncrementsNumDoseLevelsMaxTested}}
##' @return the \code{\linkS4class{IncrementsNumDoseLevelsMaxTested}} object
##'
##' @export
##' @keywords methods
IncrementsNumDoseLevelsMaxTested <- function(maxLevels=1)
{
.IncrementsNumDoseLevelsMaxTested(maxLevels=safeInteger(maxLevels))
}
## -----------------------------------------------------------
## 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)
}
## ============================================================
## --------------------------------------------------
## Virtual class for stopping rules
## --------------------------------------------------
##' The virtual class for stopping rules
##'
##' @seealso \code{\linkS4class{StoppingList}},
##' \code{\linkS4class{StoppingCohortsNearDose}},
##' \code{\linkS4class{StoppingPatientsNearDose}},
##' \code{\linkS4class{StoppingMinCohorts}},
##' \code{\linkS4class{StoppingMinPatients}},
##' \code{\linkS4class{StoppingTargetProb}}
##' \code{\linkS4class{StoppingMTDdistribution}},
##' \code{\linkS4class{StoppingTargetBiomarker}},
##' \code{\linkS4class{StoppingHighestDose}}
##' \code{\linkS4class{StoppingLowestDoseHSRBeta}},
##' \code{\linkS4class{StoppingMTDCV}},
##' \code{\linkS4class{StoppingTargetProbPatientsNearHighestDose}},
##' \code{\linkS4class{StoppingTargetProbPatientsNearLowestDose}}
##'
##' @export
##' @keywords classes
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)
}
## --------------------------------------------------
## 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
##' @keywords classes
##' @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
##' @keywords methods
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 fullfillment 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 fullfillment 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)
}
## --------------------------------------------------
## Stopping based on the lowest dose meeting the hard safety criteria using Beta based DLT probability
## --------------------------------------------------
##' Stop based on the lowest dose meeting the hard safety criteria using
##' Beta based DLT probability, i.e. 1- pbeta(target, x+a, n-x+b) < prob
##'
##' @slot target toxicity target for a dose
##' @slot prob probability of dose being toxic
##' @slot a shape parameter a>0 of probability distribution Beta (a,b)
##' @slot b shape parameter b>0 of probability distribution Beta (a,b)
##'
##' @keywords classes
##' @export
.StoppingLowestDoseHSRBeta <-
setClass(Class="StoppingLowestDoseHSRBeta",
representation(target="numeric",
prob="numeric",
a="numeric",
b="numeric"),
prototype(target=0.3,
prob=0.9,
a=1,
b=1),
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@prob,
bounds=FALSE),
"prob must be probability > 0 and < 1")
o$check(is.numeric(object@a) & object@a > 0,
"Beta distribution shape parameter a must me a real number > 0")
o$check(is.numeric(object@b) & object@b > 0,
"Beta distribution shape parameter b must me a real number > 0")
o$result()
})
validObject(.StoppingLowestDoseHSRBeta())
##' Initialization function for "StoppingLowestDoseHSRBeta"
##'
##' @param target see \code{\linkS4class{StoppingLowestDoseHSRBeta}}
##' @param prob see \code{\linkS4class{StoppingLowestDoseHSRBeta}}
##' @param a see \code{\linkS4class{StoppingLowestDoseHSRBeta}}
##' @param b see \code{\linkS4class{StoppingLowestDoseHSRBeta}}
##' @return the \code{\linkS4class{StoppingLowestDoseHSRBeta}} object
##'
##' @export
##' @keywords methods
StoppingLowestDoseHSRBeta <- function(target,prob,a,b)
{
.StoppingLowestDoseHSRBeta(target=target,
prob=prob,
a=a,
b=b)
}
## --------------------------------------------------
## Stopping based on precision of MTD calculated as CV(MTD)
## --------------------------------------------------
##' Stop based on precision of MTD calculated as CV(MTD)
##'
##' @slot target toxicity target of MTD
##' @slot thresh threshold for MTD to be considered accurate enough and stop
##' the trial
##'
##' @keywords classes
##' @export
.StoppingMTDCV <-
setClass(Class="StoppingMTDCV",
representation(target="numeric",
thresh="numeric"),
prototype(target=0.33,
thresh=0.4),
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$result()
})
validObject(.StoppingMTDCV())
##' Initialization function for "StoppingMTDCV"
##'
##' @param target see \code{\linkS4class{StoppingMTDCV}}
##' @param thresh see \code{\linkS4class{StoppingMTDCV}}
##' @return the \code{\linkS4class{StoppingMTDCV}} object
##'
##' @export
##' @keywords methods
StoppingMTDCV <- function(target,
thresh)
{
.StoppingMTDCV(target=target,
thresh=thresh)
}
## ---------------------------------------------------------------------------------------------------
## Stopping based on probability of target tox interval and number of patients near to the highest dose
## ---------------------------------------------------------------------------------------------------
##' Stop based on number of patients near to next best dose
##'
##' @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
##' @slot nPatients number of required patients
##' @slot percentage percentage (between 0 and 100) within the next best dose
##' the patients must lie
##'
##' @keywords classes
##' @export
.StoppingTargetProbPatientsNearHighestDose <-
setClass(Class="StoppingTargetProbPatientsNearHighestDose",
representation(target="numeric",
prob="numeric",
nPatients="integer",
percentage="numeric"),
prototype(target=c(0.2, 0.35),
prob=0.4,
nPatients=10L,
percentage=50),
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$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(.StoppingTargetProbPatientsNearHighestDose())
##' Initialization function for "StoppingTargetProbPatientsNearHighestDose"
##'
##' @param target see \code{\linkS4class{StoppingTargetProb}}
##' @param prob see \code{\linkS4class{StoppingTargetProb}}
##' @return the \code{\linkS4class{StoppingTargetProb}} object
##' @param nPatients see \code{\linkS4class{StoppingPatientsNearDose}}
##' @param percentage see \code{\linkS4class{StoppingPatientsNearDose}}
##' @return the \code{\linkS4class{StoppingPatientsNearDose}} object
##'
##' @export
##' @keywords methods
StoppingTargetProbPatientsNearHighestDose <- function(target,
prob,
nPatients,
percentage)
{
.StoppingTargetProbPatientsNearHighestDose(target=target,
prob=prob,
nPatients=safeInteger(nPatients),
percentage=percentage)
}
## ---------------------------------------------------------------------------------------------------
## Stopping based on probability of target tox interval and number of patients near to the lowest dose
## ---------------------------------------------------------------------------------------------------
##' Stop based on number of patients near to next best dose
##'
##' @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
##' @slot nPatients number of required patients
##' @slot percentage percentage (between 0 and 100) within the next best dose
##' the patients must lie
##'
##' @keywords classes
##' @export
.StoppingTargetProbPatientsNearLowestDose <-
setClass(Class="StoppingTargetProbPatientsNearLowestDose",
representation(target="numeric",
prob="numeric",
nPatients="integer",
percentage="numeric"),
prototype(target=c(0.2, 0.35),
prob=0.4,
nPatients=10L,
percentage=50),
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$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(.StoppingTargetProbPatientsNearLowestDose())
##' Initialization function for "StoppingTargetProbPatientsNearLowestDose"
##'
##' @param target see \code{\linkS4class{StoppingTargetProb}}
##' @param prob see \code{\linkS4class{StoppingTargetProb}}
##' @return the \code{\linkS4class{StoppingTargetProb}} object
##' @param nPatients see \code{\linkS4class{StoppingPatientsNearDose}}
##' @param percentage see \code{\linkS4class{StoppingPatientsNearDose}}
##' @return the \code{\linkS4class{StoppingPatientsNearDose}} object
##'
##' @export
##' @keywords methods
StoppingTargetProbPatientsNearLowestDose <- function(target,
prob,
nPatients,
percentage)
{
.StoppingTargetProbPatientsNearLowestDose(target=target,
prob=prob,
nPatients=safeInteger(nPatients),
percentage=percentage)
}
## ============================================================
## --------------------------------------------------
## 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 occurrrence 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 occurrrence 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 occurrrence 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 occurrrence 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)
}
0liver0815/onc-crmpack-test documentation built on Feb. 19, 2022, 12:25 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#####################################################################################
## Author: Daniel Sabanes Bove [sabanesd *a*t* roche *.* com]
## Wai Yin Yeung [ w *.* yeung1 *a*t* lancaster *.* ac *.* uk]
## Project: Object-oriented implementation of CRM designs
##
## Time-stamp: <[Rules-class.R] by DSB Die 09/06/2015 21:28>
##
## Description:
## Encapsulate the rules in formal classes.
##
## History:
## 07/02/2014 file creation
## 10/07/2014 Added further rule classs
###################################################################################
##' @include helpers.R
{}
## ============================================================
## --------------------------------------------------
## 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}},
##' \code{\linkS4class{NextBestMTDCRM}}
##'
##' @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)
}
## ------------------------------------------------------
## Next best dose based on CRM MTD allocation probability
## ------------------------------------------------------
##' The class with the input for finding the next best dose based on CRM MTD
##' allocation probability.
##'
##' @slot target the target toxicity probability
##' @slot pbomethod the method used to handle the allocation probability for the
##' zero dose. Applicable to cases where data@plabebo = "FALSE"
##' If \code{none}, then the number of simulation instances allocated to zero
##' dose, are exuded from the derivation of allocation probabilities.
##' If \code{min}, then the number of simulation instances allocated to zero
##' dose, are combined with the instances allocated to the minimum planned dose.
##' If \code{max}, then the number of simulation instances allocated to zero
##' dose, are combined with the instances allocated to the maximum planned dose.
##'
##' @export
##' @keywords classes
.NextBestMTDCRM <-
setClass(Class="NextBestMTDCRM",
representation(target="numeric",
pbomethod="character"),
prototype(target=0.3,
pbomethod="none"),
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(is.scalar(object@pbomethod) && object@pbomethod %in% c("none", "min", "max"),
"pbomethod must be either 'none' or 'min' or 'max'")
o$result()
})
validObject(.NextBestMTDCRM())
##' Initialization function for class "NextBestMTDCRM"
##'
##' @param target see \code{\linkS4class{NextBestMTDCRM}}
##' @param pbomethod see \code{\linkS4class{NextBestMTDCRM}}
##' @return the \code{\linkS4class{NextBestMTDCRM}} object
##'
##' @export
##' @keywords methods
NextBestMTDCRM <- function(target,
pbomethod=c("none", "min" , "max"))
{
pbomethod <- match.arg(pbomethod)
.NextBestMTDCRM(target=target,
pbomethod=pbomethod)
}
## ============================================================
## --------------------------------------------------
## Virtual class for increments control
## --------------------------------------------------
##' The virtual class for controlling increments
##'
##' @seealso \code{\linkS4class{IncrementsRelative}},
##' \code{\linkS4class{IncrementsRelativeDLT}},
##' \code{\linkS4class{IncrementsRelativeParts}},
##' \code{\linkS4class{IncrementsHSRBeta}},
##' \code{\linkS4class{IncrementsNumDoseLevelsMaxTested}}
##'
##' @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)
}
## --------------------------------------------------
## Increments control based on number of dose levels
## --------------------------------------------------
##' Increments control based on number of dose levels
##'
##' @slot maxLevels scalar positive integer for 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.
##'
##' @example examples/Rules-class-IncrementsNumDoseLevels.R
##' @export
##' @keywords classes
.IncrementsNumDoseLevels <-
setClass(Class="IncrementsNumDoseLevels",
representation(maxLevels="integer"),
prototype(maxLevels=1L),
contains="Increments",
validity=
function(object){
o <- Validate()
o$check(is.scalar(object@maxLevels) &&
is.integer(object@maxLevels) &&
object@maxLevels > 0,
"maxLevels must be scalar positive integer")
o$result()
})
validObject(.IncrementsNumDoseLevels())
##' Initialization function for "IncrementsNumDoseLevels"
##'
##' @param maxLevels see \code{\linkS4class{IncrementsNumDoseLevels}}
##' @return the \code{\linkS4class{IncrementsNumDoseLevels}} object
##'
##' @export
##' @keywords methods
IncrementsNumDoseLevels <- function(maxLevels=1)
{
.IncrementsNumDoseLevels(maxLevels=safeInteger(maxLevels))
}
## --------------------------------------------------
## 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)
}
## -------------------------------------------------------
## Increments control based on Hard Safety Rule - Beta(a,b)
## -------------------------------------------------------
##' Increments control based on eligable dose levels according to Hard Safety
##' Rule - Beta(a,b)
##'
##' @slot target a probability > 0 and < 1 of the target toxicity rate
##' @slot prob a probability > 0 and < 1 of the confidence of the test
##' @slot a positive real number representing the shape parameter of a Beta(a,b) distribution
##' @slot b positive real number representing the shape parameter of a Beta(a,b) distribution
##'
##' @export
##' @keywords classes
.IncrementsHSRBeta <-
setClass(Class="IncrementsHSRBeta",
representation(target="numeric",
prob="numeric",
a="numeric",
b="numeric"),
prototype(target=0.3,
prob=0.9,
a=1,
b=1),
contains="Increments",
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@prob,bounds=FALSE),
"prob must be probability > 0 and < 1")
o$check(is.numeric(object@a) & object@a > 0,
"Beta distribution shape parameter a must me a real number > 0")
o$check(is.numeric(object@b) & object@b > 0,
"Beta distribution shape parameter b must me a real number > 0")
o$result()
})
validObject(.IncrementsHSRBeta())
##' Initialization function for "IncrementsHSRBeta"
##'
##' @param target see \code{\linkS4class{IncrementsHSRBeta}}
##' @param prob see \code{\linkS4class{IncrementsHSRBeta}}
##' @param a see \code{\linkS4class{IncrementsHSRBeta}}
##' @param b see \code{\linkS4class{IncrementsHSRBeta}}
##'
##' @return the \code{\linkS4class{IncrementsHSRBeta}} object
##'
##' @export
##' @keywords methods
IncrementsHSRBeta <- function(target,prob,a,b)
{
.IncrementsHSRBeta(target=target,
prob=prob,
a=a,
b=b)
}
## -----------------------------------------------------------------------------------------
## Increments control based on number of dose levels relative to the max dose tested so far
## -----------------------------------------------------------------------------------------
##' Increments control based on number of dose levels relative to the max dose tested so far
##'
##' @slot maxLevels scalar positive integer for 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 max dose tested so far.
##'
##' @export
##' @keywords classes
.IncrementsNumDoseLevelsMaxTested <-
setClass(Class="IncrementsNumDoseLevelsMaxTested",
representation(maxLevels="integer"),
prototype(maxLevels=1L),
contains="Increments",
validity=
function(object){
o <- Validate()
o$check(is.scalar(object@maxLevels) &&
is.integer(object@maxLevels) &&
object@maxLevels > 0,
"maxLevels must be scalar positive integer")
o$result()
})
validObject(.IncrementsNumDoseLevelsMaxTested())
##' Initialization function for "IncrementsNumDoseLevelsMaxTested"
##'
##' @param maxLevels see \code{\linkS4class{IncrementsNumDoseLevelsMaxTested}}
##' @return the \code{\linkS4class{IncrementsNumDoseLevelsMaxTested}} object
##'
##' @export
##' @keywords methods
IncrementsNumDoseLevelsMaxTested <- function(maxLevels=1)
{
.IncrementsNumDoseLevelsMaxTested(maxLevels=safeInteger(maxLevels))
}
## -----------------------------------------------------------
## 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)
}
## ============================================================
## --------------------------------------------------
## Virtual class for stopping rules
## --------------------------------------------------
##' The virtual class for stopping rules
##'
##' @seealso \code{\linkS4class{StoppingList}},
##' \code{\linkS4class{StoppingCohortsNearDose}},
##' \code{\linkS4class{StoppingPatientsNearDose}},
##' \code{\linkS4class{StoppingMinCohorts}},
##' \code{\linkS4class{StoppingMinPatients}},
##' \code{\linkS4class{StoppingTargetProb}}
##' \code{\linkS4class{StoppingMTDdistribution}},
##' \code{\linkS4class{StoppingTargetBiomarker}},
##' \code{\linkS4class{StoppingHighestDose}}
##' \code{\linkS4class{StoppingLowestDoseHSRBeta}},
##' \code{\linkS4class{StoppingMTDCV}},
##' \code{\linkS4class{StoppingTargetProbPatientsNearHighestDose}},
##' \code{\linkS4class{StoppingTargetProbPatientsNearLowestDose}}
##'
##' @export
##' @keywords classes
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)
}
## --------------------------------------------------
## 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
##' @keywords classes
##' @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
##' @keywords methods
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 fullfillment 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 fullfillment 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)
}
## --------------------------------------------------
## Stopping based on the lowest dose meeting the hard safety criteria using Beta based DLT probability
## --------------------------------------------------
##' Stop based on the lowest dose meeting the hard safety criteria using
##' Beta based DLT probability, i.e. 1- pbeta(target, x+a, n-x+b) < prob
##'
##' @slot target toxicity target for a dose
##' @slot prob probability of dose being toxic
##' @slot a shape parameter a>0 of probability distribution Beta (a,b)
##' @slot b shape parameter b>0 of probability distribution Beta (a,b)
##'
##' @keywords classes
##' @export
.StoppingLowestDoseHSRBeta <-
setClass(Class="StoppingLowestDoseHSRBeta",
representation(target="numeric",
prob="numeric",
a="numeric",
b="numeric"),
prototype(target=0.3,
prob=0.9,
a=1,
b=1),
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@prob,
bounds=FALSE),
"prob must be probability > 0 and < 1")
o$check(is.numeric(object@a) & object@a > 0,
"Beta distribution shape parameter a must me a real number > 0")
o$check(is.numeric(object@b) & object@b > 0,
"Beta distribution shape parameter b must me a real number > 0")
o$result()
})
validObject(.StoppingLowestDoseHSRBeta())
##' Initialization function for "StoppingLowestDoseHSRBeta"
##'
##' @param target see \code{\linkS4class{StoppingLowestDoseHSRBeta}}
##' @param prob see \code{\linkS4class{StoppingLowestDoseHSRBeta}}
##' @param a see \code{\linkS4class{StoppingLowestDoseHSRBeta}}
##' @param b see \code{\linkS4class{StoppingLowestDoseHSRBeta}}
##' @return the \code{\linkS4class{StoppingLowestDoseHSRBeta}} object
##'
##' @export
##' @keywords methods
StoppingLowestDoseHSRBeta <- function(target,prob,a,b)
{
.StoppingLowestDoseHSRBeta(target=target,
prob=prob,
a=a,
b=b)
}
## --------------------------------------------------
## Stopping based on precision of MTD calculated as CV(MTD)
## --------------------------------------------------
##' Stop based on precision of MTD calculated as CV(MTD)
##'
##' @slot target toxicity target of MTD
##' @slot thresh threshold for MTD to be considered accurate enough and stop
##' the trial
##'
##' @keywords classes
##' @export
.StoppingMTDCV <-
setClass(Class="StoppingMTDCV",
representation(target="numeric",
thresh="numeric"),
prototype(target=0.33,
thresh=0.4),
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$result()
})
validObject(.StoppingMTDCV())
##' Initialization function for "StoppingMTDCV"
##'
##' @param target see \code{\linkS4class{StoppingMTDCV}}
##' @param thresh see \code{\linkS4class{StoppingMTDCV}}
##' @return the \code{\linkS4class{StoppingMTDCV}} object
##'
##' @export
##' @keywords methods
StoppingMTDCV <- function(target,
thresh)
{
.StoppingMTDCV(target=target,
thresh=thresh)
}
## ---------------------------------------------------------------------------------------------------
## Stopping based on probability of target tox interval and number of patients near to the highest dose
## ---------------------------------------------------------------------------------------------------
##' Stop based on number of patients near to next best dose
##'
##' @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
##' @slot nPatients number of required patients
##' @slot percentage percentage (between 0 and 100) within the next best dose
##' the patients must lie
##'
##' @keywords classes
##' @export
.StoppingTargetProbPatientsNearHighestDose <-
setClass(Class="StoppingTargetProbPatientsNearHighestDose",
representation(target="numeric",
prob="numeric",
nPatients="integer",
percentage="numeric"),
prototype(target=c(0.2, 0.35),
prob=0.4,
nPatients=10L,
percentage=50),
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$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(.StoppingTargetProbPatientsNearHighestDose())
##' Initialization function for "StoppingTargetProbPatientsNearHighestDose"
##'
##' @param target see \code{\linkS4class{StoppingTargetProb}}
##' @param prob see \code{\linkS4class{StoppingTargetProb}}
##' @return the \code{\linkS4class{StoppingTargetProb}} object
##' @param nPatients see \code{\linkS4class{StoppingPatientsNearDose}}
##' @param percentage see \code{\linkS4class{StoppingPatientsNearDose}}
##' @return the \code{\linkS4class{StoppingPatientsNearDose}} object
##'
##' @export
##' @keywords methods
StoppingTargetProbPatientsNearHighestDose <- function(target,
prob,
nPatients,
percentage)
{
.StoppingTargetProbPatientsNearHighestDose(target=target,
prob=prob,
nPatients=safeInteger(nPatients),
percentage=percentage)
}
## ---------------------------------------------------------------------------------------------------
## Stopping based on probability of target tox interval and number of patients near to the lowest dose
## ---------------------------------------------------------------------------------------------------
##' Stop based on number of patients near to next best dose
##'
##' @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
##' @slot nPatients number of required patients
##' @slot percentage percentage (between 0 and 100) within the next best dose
##' the patients must lie
##'
##' @keywords classes
##' @export
.StoppingTargetProbPatientsNearLowestDose <-
setClass(Class="StoppingTargetProbPatientsNearLowestDose",
representation(target="numeric",
prob="numeric",
nPatients="integer",
percentage="numeric"),
prototype(target=c(0.2, 0.35),
prob=0.4,
nPatients=10L,
percentage=50),
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$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(.StoppingTargetProbPatientsNearLowestDose())
##' Initialization function for "StoppingTargetProbPatientsNearLowestDose"
##'
##' @param target see \code{\linkS4class{StoppingTargetProb}}
##' @param prob see \code{\linkS4class{StoppingTargetProb}}
##' @return the \code{\linkS4class{StoppingTargetProb}} object
##' @param nPatients see \code{\linkS4class{StoppingPatientsNearDose}}
##' @param percentage see \code{\linkS4class{StoppingPatientsNearDose}}
##' @return the \code{\linkS4class{StoppingPatientsNearDose}} object
##'
##' @export
##' @keywords methods
StoppingTargetProbPatientsNearLowestDose <- function(target,
prob,
nPatients,
percentage)
{
.StoppingTargetProbPatientsNearLowestDose(target=target,
prob=prob,
nPatients=safeInteger(nPatients),
percentage=percentage)
}
## ============================================================
## --------------------------------------------------
## 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 occurrrence 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 occurrrence 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 occurrrence 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 occurrrence 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)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.