Nothing
#' Demand there are n patients at a dose before condisdering stopping.
#'
#' This method continues a dose-finding trial until there are n patients at a
#' dose. Once that condition is met, it delegates stopping responsibility to its
#' parent dose selector, whatever that might be. This class is greedy in that it
#' meets its own needs before asking any other selectors in a chain what they
#' want. Thus, different behaviours may be achieved by nesting dose selectors
#' in different orders. See examples.
#'
#'
#' @param parent_selector_factory Object of type \code{\link{selector_factory}}.
#' @param n Continue at least until there are n at a dose.
#' @param dose \code{'any'} to continue until there are n at any dose;
#' \code{'recommended'} to continue until there are n at the recommended dose;
#' or an integer to continue until there are n at a particular dose-level.
#'
#' @return an object of type \code{\link{selector_factory}} that can fit a
#' dose-finding model to outcomes.
#'
#' @export
#'
#' @examples
#' skeleton <- c(0.05, 0.1, 0.25, 0.4, 0.6)
#' target <- 0.25
#'
#' # This model will demand 9 at any dose before it countenances stopping.
#' model1 <- get_dfcrm(skeleton = skeleton, target = target) %>%
#' demand_n_at_dose(n = 9, dose = 'any')
#'
#' # This model will recommend continuing:
#' model1 %>% fit('1NNT 1NNN 2TNN 2NNN') %>% continue()
#' # It tells you to continue because there is no selector considering when
#' # you should stop - dfcrm implements no stopping rule by default.
#'
#' # In contrast, we can add a stopping selector to discern the behaviour of
#' # demand_n_at_dose. We will demand 9 are seen at the recommended dose before
#' # stopping is permitted in model3:
#' model2 <- get_dfcrm(skeleton = skeleton, target = target) %>%
#' stop_at_n(n = 12)
#' model3 <- get_dfcrm(skeleton = skeleton, target = target) %>%
#' stop_at_n(n = 12) %>%
#' demand_n_at_dose(n = 9, dose = 'recommended')
#'
#' # This model advocates stopping because 12 patients are seen in total:
#' model2 %>% fit('1NNN 1NNN 2TNN 2NNN') %>% continue()
#' # But this model advocates continuing because 9 patients have not been seen
#' # at any dose yet:
#' model3 %>% fit('1NNN 1NNN 2TNN 2NNN') %>% continue()
#' # This shows how demand_n_at_dose overrides stopping behaviours that come
#' # before it in the daisychain.
#'
#' # Once 9 are seen at the recommended dose, the decision to stop is made:
#' fit <- model3 %>% fit('1NNN 1NNN 2TNN 2NNN 2TTN')
#' fit %>% continue()
#' fit %>% recommended_dose()
demand_n_at_dose <- function(parent_selector_factory, n, dose) {
x <- list(
parent = parent_selector_factory,
n = n,
dose = dose
)
class(x) <- c('demand_n_at_dose_selector_factory',
'derived_dose_selector_factory',
'selector_factory')
return(x)
}
demand_n_at_dose_selector <- function(parent_selector, n, dose) {
l <- list(
parent = parent_selector,
n = n,
dose = dose
)
class(l) = c('demand_n_at_dose_selector',
'derived_dose_selector',
'selector')
l
}
# Factory interface
#' @importFrom magrittr %>%
#' @export
fit.demand_n_at_dose_selector_factory <- function(selector_factory,
outcomes, ...) {
parent_selector <- selector_factory$parent %>%
fit(outcomes, ...)
return(demand_n_at_dose_selector(parent_selector = parent_selector,
n = selector_factory$n,
dose = selector_factory$dose))
}
# Selector interface
#' @importFrom magrittr %>%
#' @export
continue.demand_n_at_dose_selector <- function(x, ...) {
# This selector affects when a trial ends but not which dose is selected.
# If the parent selects no dose, this selector changes nothing.
parent_dose <- x$parent %>% recommended_dose()
if(is.na(parent_dose)) {
return(x$parent %>% continue())
} else {
n_at_dose <- x %>% n_at_dose()
if(x$dose == 'any') {
if(any(n_at_dose >= x$n)) {
return(x$parent %>% continue())
} else {
return(TRUE)
}
}
else if(x$dose == 'recommended') {
rec_dose <- x %>% recommended_dose()
if(n_at_dose[rec_dose] >= x$n) {
return(x$parent %>% continue())
} else {
return(TRUE)
}
}
else if(x$dose >= 1 & x$dose <= x %>% num_doses()) {
if(n_at_dose[x$dose] >= x$n) {
return(x$parent %>% continue())
} else {
return(TRUE)
}
}
# By default:
return(x$parent %>% continue())
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.