crmPack coverage - 78.95%

Files
Source

#' @include helpers.R
#' @include McmcOptions-validity.R
#' @include CrmPackClass-class.R
NULL

# McmcOptions ----

## class ----

#' `McmcOptions`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`McmcOptions`] is a class for the three canonical MCMC options as well as
#' Random Number Generator settings.
#'
#' @slot iterations (`count`)\cr number of MCMC iterations.
#' @slot burnin (`count`)\cr number of burn-in iterations which are not saved.
#' @slot step (`count`)\cr only every `step`-th iteration is saved after
#'   the `burnin`. In other words, a sample from iteration
#'   `i = 1,...,iterations`, is saved if and only if
#'   `(i - burnin) mod step = 0`.\cr
#'   For example, for `iterations = 6`, `burnin = 0` and `step = 2`, only
#'   samples from iterations `2,4,6` will be saved.
#' @slot rng_kind (`string`)\cr a Random Number Generator (RNG) type used by
#'   [`rjags`]. It must be one out of the following four values:
#'   `base::Wichmann-Hill`, `base::Marsaglia-Multicarry`,
#'   `base::Super-Duper`, `base::Mersenne-Twister`, or `NA_character_`.
#'   If it is `NA_character_` (default), then the RNG kind will be chosen by
#'   [`rjags`].
#' @slot rng_seed (`number`)\cr a Random Number Generator (RNG) seed
#'   used by [`rjags`] for a chosen `rng_kind`. It must be an integer scalar or
#'   `NA_integer_`, which means that the seed will be chosen by [`rjags`].
#'
#' @aliases McmcOptions
#' @export
#'
.McmcOptions <- setClass(
  Class = "McmcOptions",
  slots = c(
    iterations = "integer",
    burnin = "integer",
    step = "integer",
    rng_kind = "character",
    rng_seed = "integer"
  ),
  prototype = prototype(
    iterations = 1000L,
    burnin = 100L,
    step = 2L,
    rng_kind = NA_character_,
    rng_seed = NA_integer_
  ),
  contains = "CrmPackClass",
  validity = v_mcmc_options
)

## constructor ----

#' @rdname McmcOptions-class
#'
#' @param burnin (`count`)\cr number of burn-in iterations which are not saved.
#' @param step (`count`)\cr only every step-th iteration is saved after
#'   the burn-in.
#' @param samples (`count`)\cr number of resulting samples.
#' @param rng_kind (`string`)\cr the name of the RNG type. Possible types are:
#'   `Wichmann-Hill`, `Marsaglia-Multicarry`, `Super-Duper`, `Mersenne-Twister`.
#'   If it is `NA` (default), then the RNG kind will be chosen by `[rjags`].
#' @param rng_seed (`number`)\cr RNG seed corresponding to chosen `rng_kind`.
#'   It must be an integer value or `NA` (default), which means that the seed
#'   will be chosen by `[rjags`].
#'
#' @export
#' @example examples/McmcOptions-class-McmcOptions.R
#'
McmcOptions <- function(
  burnin = 1e4L,
  step = 2L,
  samples = 1e4L,
  rng_kind = NA_character_,
  rng_seed = NA_integer_
) {
  assert_count(burnin, positive = TRUE)
  assert_count(step, positive = TRUE)
  assert_count(samples, positive = TRUE)
  assert_string(rng_kind, na.ok = TRUE)
  assert_count(rng_seed, na.ok = TRUE)

  if (!is.na(rng_kind)) {
    rng_kind <- paste0("base::", rng_kind)
  } else {
    rng_kind <- NA_character_
  }
  if (!is.na(rng_seed)) {
    rng_seed <- as.integer(rng_seed)
  } else {
    rng_seed <- NA_integer_
  }

  .McmcOptions(
    iterations = as.integer(burnin + (step * samples)),
    burnin = as.integer(burnin),
    step = as.integer(step),
    rng_kind = rng_kind,
    rng_seed = as.integer(rng_seed)
  )
}

## default constructor ----

#' @rdname McmcOptions-class
#' @note Typically, end users will not use the `.DefaultMcmcOptions()` function.
#' @export
.DefaultMcmcOptions <- function() {
  McmcOptions(
    burnin = 250,
    samples = 1000
  )
}

#' @include helpers.R
#' @include Data-validity.R
#' @include CrmPackClass-class.R
NULL

# GeneralData-class ----

#' `GeneralData`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`GeneralData`] is a class for general data input.
#'
#' @slot ID (`integer`)\cr unique patient IDs.
#' @slot cohort (`integer`)\cr the cohort (non-negative sorted) indices.
#' @slot nObs (`integer`)\cr number of observations, a single value.
#'
#' @aliases GeneralData
#' @export
#'
.GeneralData <- setClass(
  Class = "GeneralData",
  slots = c(
    ID = "integer",
    cohort = "integer",
    nObs = "integer"
  ),
  prototype = prototype(
    ID = integer(),
    cohort = integer(),
    nObs = 0L
  ),
  contains = "CrmPackClass",
  validity = v_general_data
)

## default constructor ----

#' @rdname GeneralData-class
#' @note Typically, end users will not use the `.DefaultDataGeneral()` function.
#' @export
.DefaultDataGeneral <- function() {
  stop(paste0(
    "Class DataGeneral cannot be instantiated directly.  Please use one of its subclasses instead."
  ))
}

# Data ----

## class ----

#' `Data`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Data`] is a class for the data input.
#' It inherits from [`GeneralData`].
#'
#' @slot x (`numeric`)\cr the doses for the patients.
#' @slot y (`integer`)\cr the vector of toxicity events (0 or 1 integers).
#' @slot doseGrid (`numeric`)\cr the vector of all possible doses (sorted),
#'   i.e. the dose grid.
#' @slot nGrid (`integer`)\cr number of gridpoints.
#' @slot xLevel (`integer`)\cr the levels for the doses the patients have been given,
#'   w.r.t `doseGrid`.
#' @slot placebo (`logical`)\cr if `TRUE` the first dose level
#'   in the `doseGrid`is considered as PLACEBO.
#'
#' @aliases Data
#' @export
#'
.Data <- setClass(
  Class = "Data",
  contains = "GeneralData",
  slots = c(
    x = "numeric",
    y = "integer",
    doseGrid = "numeric",
    nGrid = "integer",
    xLevel = "integer",
    placebo = "logical"
  ),
  prototype = prototype(
    x = numeric(),
    y = integer(),
    doseGrid = numeric(),
    nGrid = 0L,
    xLevel = integer(),
    placebo = FALSE
  ),
  validity = v_data
)

## constructor ----

#' @rdname Data-class
#'
#' @details The `cohort` can be missing if and only if `placebo` is equal to
#'   `FALSE`.
#'
#' @note `ID` and `cohort` can be missing. Then a message will be issued
#'   and the variables will be filled with default IDs and best guesses cohort,
#'   i.e. a sorted (in ascending order) sequence of values from `{1, 2, ...}`.
#'
#' @param x (`numeric`)\cr the doses for the patients.
#' @param y (`integer`)\cr the vector of toxicity events (0 or 1).
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param ID (`integer`)\cr unique patient IDs.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param cohort (`integer`)\cr the cohort (non-negative sorted) indices.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param doseGrid (`numeric`)\cr all possible doses.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level
#'   in the `doseGrid` is considered as placebo.
#' @param ... not used.
#'
#' @export
#' @example examples/Data-class.R
#'
Data <- function(
  x = numeric(),
  y = integer(),
  ID = integer(),
  cohort = integer(),
  doseGrid = numeric(),
  placebo = FALSE,
  ...
) {
  assert_numeric(x)
  assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE)
  assert_integerish(ID, unique = TRUE, any.missing = FALSE)
  assert_integerish(cohort)
  if (length(x) > 0) {
    assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE, min.len = 1)
  } else {
    assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
  }
  assert_flag(placebo)

  doseGrid <- sort(doseGrid)
  assert_subset(x, doseGrid)

  if (length(ID) == 0 && length(x) > 0) {
    message("Used default patient IDs!")
    ID <- seq_along(x)
  } else {
    assert_integerish(ID, unique = TRUE)
  }

  if (!placebo && length(cohort) == 0 && length(x) > 0) {
    message("Used best guess cohort indices!")
    # This is just assuming that consecutive patients
    # in the data set are in the same cohort if they
    # have the same dose. Note that this could be wrong,
    # if two subsequent cohorts are at the same dose.
    cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
  } else {
    assert_integerish(cohort)
  }

  .Data(
    x = as.numeric(x),
    y = as.integer(y),
    ID = as.integer(ID),
    cohort = as.integer(cohort),
    doseGrid = as.numeric(doseGrid),
    nObs = length(x),
    nGrid = length(doseGrid),
    xLevel = match_within_tolerance(x, doseGrid),
    placebo = placebo
  )
}

## default constructor ----

#' @rdname Data-class
#' @note Typically, end users will not use the `.DefaultData()` function.
#' @export
.DefaultData <- function() {
  Data(
    doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
    ID = 1L:3L,
    cohort = 1L:3L,
    x = c(1, 3, 5),
    y = rep(0L, 3)
  )
}

# DataDual ----

## class ----

#' `DataDual`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataDual`] is a class for the dual endpoint data.
#' It inherits from [`Data`] and it contains additional biomarker information.
#'
#' @slot w (`numeric`)\cr the continuous vector of biomarker values.
#'
#' @aliases DataDual
#' @export
#'
.DataDual <- setClass(
  Class = "DataDual",
  slots = c(w = "numeric"),
  prototype = prototype(w = numeric()),
  contains = "Data",
  validity = v_data_dual
)

## constructor ----

#' @rdname DataDual-class
#'
#' @param w (`numeric`)\cr the continuous vector of biomarker values.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataDual.R
#'
DataDual <- function(w = numeric(), ...) {
  d <- Data(...)
  .DataDual(d, w = w)
}


## default constructor ----

#' @rdname DataDual-class
#' @note Typically, end users will not use the `.DefaultDataDual()` function.
#' @export
.DefaultDataDual <- function() {
  set.seed(1230)
  DataDual(
    x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
    y = c(0, 0, 0, 0, 0, 0, 1, 0),
    w = rnorm(8),
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
  )
}

# DataParts ----

## class ----

#' `DataParts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataParts`] is a class for the data with two study parts.
#' It inherits from [`Data`] and it contains additional information
#' on the two study parts.
#'
#' @slot part (`integer`)\cr which part does each of the patients belong to?
#' @slot nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
#' @slot part1Ladder (`numeric`)\cr what is the escalation ladder for
#'   part 1? This shall be an ordered subset of the `doseGrid`.
#'
#' @aliases DataParts
#' @export
#'
.DataParts <- setClass(
  Class = "DataParts",
  slots = c(
    part = "integer",
    nextPart = "integer",
    part1Ladder = "numeric"
  ),
  prototype = prototype(
    part = integer(),
    nextPart = 1L,
    part1Ladder = numeric()
  ),
  contains = "Data",
  validity = v_data_parts
)

## constructor ----

#' @rdname DataParts-class
#'
#' @param part (`integer`)\cr which part does each of the patients belong to?
#' @param nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
#' @param part1Ladder (`numeric`)\cr what is the escalation ladder for part 1?
#'   This shall be an ordered subset of the `doseGrid`.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataParts.R
#'
DataParts <- function(
  part = integer(),
  nextPart = 1L,
  part1Ladder = numeric(),
  ...
) {
  d <- Data(...)
  .DataParts(
    d,
    part = part,
    nextPart = nextPart,
    part1Ladder = part1Ladder
  )
}

## default constructor ----

#' @rdname DataParts-class
#' @note Typically, end users will not use the `.DefaultDataParts()` function.
#' @export
.DefaultDataParts <- function() {
  DataParts(
    x = c(0.1, 0.5, 1.5),
    y = c(0, 0, 0),
    ID = 1:3,
    cohort = 1:3,
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    part = c(1L, 1L, 1L),
    nextPart = 1L,
    part1Ladder = c(0.1, 0.5, 1.5, 3, 6, 10)
  )
}


# DataMixture ----

## class ----

#' `DataMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataMixture`] is a class for the data with mixture sharing.
#' It inherits from [`Data`] and it contains additional information
#' on the mixture sharing.
#'
#' @slot xshare (`numeric`)\cr the doses for the share patients.
#' @slot yshare (`integer`)\cr the vector of toxicity events (0 or 1)
#'   for the share patients.
#' @slot nObsshare (`count`)\cr number of share patients.
#'
#' @aliases DataMixture
#' @export
#'
.DataMixture <- setClass(
  Class = "DataMixture",
  slots = c(
    xshare = "numeric",
    yshare = "integer",
    nObsshare = "integer"
  ),
  prototype = prototype(
    xshare = numeric(),
    yshare = integer(),
    nObsshare = 0L
  ),
  contains = "Data",
  validity = v_data_mixture
)

## constructor ----

#' @rdname DataMixture-class
#'
#' @param xshare (`numeric`)\cr the doses for the share patients.
#' @param yshare (`integer`)\cr the vector of toxicity events (0 or 1)
#'   for the share patients. You can also supply `numeric` vectors,
#'   but these will then be converted to `integer` internally.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataMixture.R
#'
DataMixture <- function(xshare = numeric(), yshare = integer(), ...) {
  d <- Data(...)
  assert_integerish(yshare)
  assert_numeric(xshare)
  .DataMixture(
    d,
    xshare = as.numeric(xshare),
    yshare = as.integer(yshare),
    nObsshare = length(xshare)
  )
}

## default constructor ----

#' @rdname DataMixture-class
#' @note Typically, end users will not use the `.DefaultDataMixture()` function.
#' @export
.DefaultDataMixture <- function() {
  DataMixture(
    xshare = c(12, 14, 16, 18.0),
    yshare = c(0L, 1L, 1L, 1L),
    nObsshare = 4L,
    x = c(0.1, 0.5, 1.5),
    y = c(0, 0, 0),
    ID = 1L:3L,
    cohort = 1L:3L,
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2))
  )
}


# DataDA ----

## class ----

#' `DataDA`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataDA`] is a class for the time-to-DLT augmented data.
#' It inherits from [`Data`] and it contains additional DLT free survival times.
#'
#' @note `survival time` here refers to the time period for which the subject
#'   did not experience any DLT, and is not referring to deaths.
#'
#' @slot u (`numeric`)\cr the continuous vector of DLT free survival times.
#' @slot t0 (`numeric`)\cr time of initial dosing for each patient.
#'   Non-negative values sorted in ascending order.
#' @slot Tmax (`number`)\cr the DLT observation period.
#'
#' @aliases DataDA
#' @export
#'
.DataDA <- setClass(
  Class = "DataDA",
  slots = c(
    u = "numeric",
    t0 = "numeric",
    Tmax = "numeric"
  ),
  prototype = prototype(
    u = numeric(),
    t0 = numeric(),
    Tmax = 0 + .Machine$double.xmin
  ),
  contains = "Data",
  validity = v_data_da
)

## constructor ----

#' @rdname DataDA-class
#'
#' @param u (`numeric`)\cr the continuous vector of DLT free survival times.
#' @param t0 (`numeric`)\cr time of initial dosing for each patient.
#'   Non-negative values sorted in ascending order.
#'   Default to vector of 0s of length equal to length of `u`.
#' @param Tmax (`number`)\cr the DLT observation period.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataDA.R
#'
DataDA <- function(
  u = numeric(),
  t0 = numeric(length(u)),
  Tmax = 0 + .Machine$double.xmin,
  ...
) {
  d <- Data(...)
  .DataDA(
    d,
    u = as.numeric(u),
    t0 = as.numeric(t0),
    Tmax = as.numeric(Tmax)
  )
}

## default constructor ----

#' @rdname DataDA-class
#' @note Typically, end users will not use the `.DefaultDataDA()` function.
#' @export
.DefaultDataDA <- function() {
  DataDA(
    u = c(42, 30, 15, 5, 20, 25, 30, 60),
    t0 = c(0, 15, 30, 40, 55, 70, 75, 85),
    Tmax = 60,
    x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
    y = c(0, 0, 1, 1, 0, 0, 1, 0),
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
  )
}

# DataOrdinal ----

## class ----

#' `DataOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DataOrdinal`] is a class for ordinal toxicity data.
#' It inherits from [`GeneralData`] and it describes toxicity responses on an
#' ordinal rather than binary scale.
#'
#' @note This class has been implemented as a sibling of the existing `Data` class
#' (rather than as a parent or child) to minimise the risk of unintended side
#' effects on existing classes and methods.
#'
#' The default setting for the `yCategories` slot replicates the behaviour
#' of the existing `Data` class.
#'
#' @aliases DataOrdinal
#' @export
.DataOrdinal <- setClass(
  Class = "DataOrdinal",
  contains = "GeneralData",
  slots = c(
    x = "numeric",
    y = "integer",
    doseGrid = "numeric",
    nGrid = "integer",
    xLevel = "integer",
    yCategories = "integer",
    placebo = "logical"
  ),
  prototype = prototype(
    x = numeric(),
    y = integer(),
    doseGrid = numeric(),
    nGrid = 0L,
    xLevel = integer(),
    yCategories = c("No DLT" = 0L, "DLT" = 1L),
    placebo = FALSE
  ),
  validity = v_data_ordinal
)

## constructor ----

#' @rdname DataOrdinal-class
#' @param yCategories (named `integer`)\cr the names and codes for the
#' toxicity categories used in the data.  Category labels are taken from the
#' names of the vector.  The names of the vector must be unique and its values
#' must be sorted and take the values 0, 1, 2, ...
#' @inheritParams Data
#' @inherit Data details note params
#' @example examples/Data-class-DataOrdinal.R
#' @export
DataOrdinal <- function(
  x = numeric(),
  y = integer(),
  ID = integer(),
  cohort = integer(),
  doseGrid = numeric(),
  placebo = FALSE,
  yCategories = c("No DLT" = 0L, "DLT" = 1L),
  ...
) {
  assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
  assert_integerish(
    yCategories,
    any.missing = FALSE,
    unique = TRUE,
    names = "unique",
    min.len = 2
  )
  assert_flag(placebo)

  doseGrid <- as.numeric(sort(doseGrid))

  if (length(ID) == 0 && length(x) > 0) {
    message("Used default patient IDs!")
    ID <- seq_along(x)
  } else {
    assert_integerish(ID, unique = TRUE)
  }

  if (!placebo && length(cohort) == 0 && length(x) > 0) {
    message("Used best guess cohort indices!")
    # This is just assuming that consecutive patients
    # in the data set are in the same cohort if they
    # have the same dose. Note that this could be wrong,
    # if two subsequent cohorts are at the same dose.
    cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
  } else {
    assert_integerish(cohort)
  }

  .DataOrdinal(
    x = as.numeric(x),
    y = as.integer(y),
    ID = as.integer(ID),
    cohort = as.integer(cohort),
    doseGrid = doseGrid,
    nObs = length(x),
    nGrid = length(doseGrid),
    xLevel = match_within_tolerance(x = x, table = doseGrid),
    placebo = placebo,
    yCategories = yCategories
  )
}


## default constructor ----

#' @rdname DataOrdinal-class
#' @note Typically, end users will not use the `.DefaultDataOrdinal()` function.
#' @export
.DefaultDataOrdinal <- function() {
  DataOrdinal(
    x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
    y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
    ID = 1L:10L,
    cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
    doseGrid = c(seq(from = 10, to = 100, by = 10)),
    yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
    placebo = FALSE
  )
}

# DataGrouped ----

## class ----

#' `DataGrouped`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataGrouped`] is a class for a two groups dose escalation data set,
#' comprised of a monotherapy (`mono`) and a combination therapy (`combo`)
#' arm. It inherits from [`Data`] and it contains the additional group information.
#'
#' @slot group (`factor`)\cr whether `mono` or `combo` was used.
#'
#' @aliases DataGrouped
#' @export
.DataGrouped <- setClass(
  Class = "DataGrouped",
  slots = c(
    group = "factor"
  ),
  prototype = prototype(
    group = factor(levels = c("mono", "combo"))
  ),
  contains = "Data",
  validity = v_data_grouped
)

#' @rdname DataGrouped-class
#'
#' @param group (`factor` or `character`)\cr whether `mono` or `combo` was used.
#'   If `character` then will be coerced to `factor` with the correct levels
#'   internally.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataGrouped.R
#'
DataGrouped <- function(group = character(), ...) {
  d <- Data(...)
  if (!is.factor(group)) {
    assert_character(group)
    assert_subset(group, choices = c("mono", "combo"))
    group <- factor(group, levels = c("mono", "combo"))
  }
  .DataGrouped(
    d,
    group = group
  )
}

## default constructor ----

#' @rdname DataGrouped-class
#' @note Typically, end users will not use the `.DefaultDataGrouped()` function.
#' @export
.DefaultDataGrouped <- function() {
  DataGrouped(
    group = c("mono", "mono", "combo"),
    x = c(1, 3, 5),
    y = c(0, 0, 0),
    ID = 1L:3L,
    cohort = 1L:3L,
    doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
    placebo = FALSE
  )
}

#' @include checkmate.R
#' @include Model-methods.R
#' @include Samples-class.R
#' @include Rules-class.R
#' @include helpers.R
#' @include helpers_rules.R
#' @include helpers_broom.R
NULL

# nextBest ----

## generic ----

#' Finding the Next Best Dose
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the recommended next best dose based on the
#' corresponding rule `nextBest`, the posterior `samples` from the `model` and
#' the underlying `data`.
#'
#' @param nextBest (`NextBest`)\cr the rule for the next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose. If it is an
#'   infinity (default), then essentially no dose limit will be applied in the
#'   course of dose recommendation calculation.
#' @param samples (`Samples`)\cr posterior samples from `model` parameters given
#'   `data`.
#' @param model (`GeneralModel`)\cr model that was used to generate the samples.
#' @param data (`Data`)\cr data that was used to generate the samples.
#' @param ... additional arguments without method dispatch.
#'
#' @return A list with the next best dose recommendation  (element named `value`)
#'   from the grid defined in `data`, and a plot depicting this recommendation
#'   (element named `plot`). In case of multiple plots also an element
#'   named `singlePlots` is included. The `singlePlots` is itself a list with
#'   single plots. An additional list with elements describing the outcome
#'   of the rule can be contained too.
#'
#' @export
#'
setGeneric(
  name = "nextBest",
  def = function(nextBest, doselimit, samples, model, data, ...) {
    if (!missing(doselimit)) {
      assert_number(doselimit, lower = 0, finite = FALSE)
    }
    standardGeneric("nextBest")
  },
  valueClass = "list"
)

## NextBestMTD ----

#' @describeIn nextBest find the next best dose based on the MTD rule.
#'
#' @aliases nextBest-NextBestMTD
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestMTD.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMTD",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Generate the MTD samples and derive the next best dose.
    dose_target_samples <- dose(x = nextBest@target, model, samples, ...)
    dose_target <- nextBest@derive(dose_target_samples)

    # Round to the next possible grid point.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )
    next_dose_level <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level]

    # Create a plot.
    p <- ggplot(
      data = data.frame(x = dose_target_samples),
      aes(.data$x),
      fill = "grey50",
      colour = "grey50"
    ) +
      geom_density() +
      coord_cartesian(xlim = range(data@doseGrid)) +
      geom_vline(xintercept = dose_target, colour = "black", lwd = 1.1) +
      geom_text(
        data = data.frame(x = dose_target),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = 0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("MTD") +
      ylab("Posterior density")

    if (is.finite(doselimit)) {
      p <- p +
        geom_vline(xintercept = doselimit, colour = "red", lwd = 1.1) +
        geom_text(
          data = data.frame(x = doselimit),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -0.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(xintercept = next_dose, colour = "blue", lwd = 1.1) +
      geom_text(
        data = data.frame(x = next_dose),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -1.5,
        colour = "blue",
        angle = 90
      )

    list(value = next_dose, plot = p)
  }
)

## NextBestNCRM ----

#' @describeIn nextBest find the next best dose based on the NCRM method. The
#'   additional element `probs` in the output's list contains the target and
#'   overdosing probabilities (across all doses in the dose grid) used in the
#'   derivation of the next best dose.
#'
#' @aliases nextBest-NextBestNCRM
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestNCRM.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestNCRM",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples,
      ...
    )

    # Estimates of posterior probabilities that are based on the prob. samples
    # which are within overdose/target interval.
    prob_overdose <- colMeans(h_in_range(
      prob_samples,
      nextBest@overdose,
      bounds_closed = c(FALSE, TRUE)
    ))
    prob_target <- colMeans(h_in_range(prob_samples, nextBest@target))

    # Eligible grid doses after accounting for maximum possible dose and discarding overdoses.
    is_dose_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo,
      levels = TRUE
    ) &
      (prob_overdose <= nextBest@max_overdose_prob)

    next_dose <- if (any(is_dose_eligible)) {
      # If maximum target probability is higher than some numerical threshold,
      # then take that level, otherwise stick to the maximum level that is OK.
      # next_best_level is relative to eligible doses.
      next_best_level <- ifelse(
        test = any(prob_target[is_dose_eligible] > 0.05),
        yes = which.max(prob_target[is_dose_eligible]),
        no = sum(is_dose_eligible)
      )
      data@doseGrid[is_dose_eligible][next_best_level]
    } else {
      NA_real_
    }

    # Build plots, first for the target probability.
    p1 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_target * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "darkgreen",
        fill = "darkgreen"
      ) +
      coord_cartesian(ylim = c(0, 100)) +
      ylab(paste("Target probability [%]"))

    if (is.finite(doselimit)) {
      p1 <- p1 +
        geom_vline(xintercept = doselimit, lwd = 1.1, lty = 2, colour = "black")
    }

    if (any(is_dose_eligible)) {
      p1 <- p1 +
        geom_vline(
          xintercept = data@doseGrid[sum(is_dose_eligible)],
          lwd = 1.1,
          lty = 2,
          colour = "red"
        ) +
        geom_point(
          data = data.frame(
            x = next_dose,
            y = prob_target[is_dose_eligible][next_best_level] * 100 + 0.03
          ),
          aes(x = x, y = y),
          size = 3,
          pch = 25,
          col = "red",
          bg = "red"
        )
    }

    # Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_overdose * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      geom_hline(
        yintercept = nextBest@max_overdose_prob * 100,
        lwd = 1.1,
        lty = 2,
        colour = "black"
      ) +
      ylim(c(0, 100)) +
      ylab("Overdose probability [%]")

    # Place them below each other.
    plot_joint <- gridExtra::arrangeGrob(p1, p2, nrow = 2)

    list(
      value = next_dose,
      plot = plot_joint,
      singlePlots = list(plot1 = p1, plot2 = p2),
      probs = cbind(
        dose = data@doseGrid,
        target = prob_target,
        overdose = prob_overdose
      )
    )
  }
)

## NextBestNCRM-DataParts ----

#' @describeIn nextBest find the next best dose based on the NCRM method when
#'   two parts trial is used.
#'
#' @aliases nextBest-NextBestNCRM-DataParts
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestNCRM-DataParts.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestNCRM",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "DataParts"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Exception when we are in part I or about to start part II!
    if (all(data@part == 1L)) {
      # Propose the highest possible dose (assuming that the dose limit came
      # from reasonable increments rule, i.e. incrementsRelativeParts).
      if (is.infinite(doselimit)) {
        stop("A finite doselimit needs to be specified for Part I.")
      }
      list(value = doselimit, plot = NULL)
    } else {
      # Otherwise we will just do the standard thing.
      callNextMethod(nextBest, doselimit, samples, model, data, ...)
    }
  }
)

## NextBestNCRMLoss ----

#' @describeIn nextBest find the next best dose based on the NCRM method and
#'   loss function.
#'
#' @aliases nextBest-NextBestNCRMLoss
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestNCRMLoss.R
#'
setMethod(
  "nextBest",
  signature = signature(
    nextBest = "NextBestNCRMLoss",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples,
      ...
    )
    # Compute probabilities to be in target and overdose tox interval.
    prob_underdosing <- colMeans(prob_samples < nextBest@target[1])
    prob_target <- colMeans(h_in_range(prob_samples, nextBest@target))
    prob_overdose <- colMeans(h_in_range(
      prob_samples,
      nextBest@overdose,
      bounds_closed = c(FALSE, TRUE)
    ))
    prob_mean <- colMeans(prob_samples)
    prob_sd <- apply(prob_samples, 2, stats::sd)

    is_unacceptable_specified <- any(nextBest@unacceptable != c(1, 1))

    prob_mat <- if (!is_unacceptable_specified) {
      cbind(
        underdosing = prob_underdosing,
        target = prob_target,
        overdose = prob_overdose
      )
    } else {
      prob_unacceptable <- colMeans(
        h_in_range(
          prob_samples,
          nextBest@unacceptable,
          bounds_closed = c(FALSE, TRUE)
        )
      )
      prob_excessive <- prob_overdose
      prob_overdose <- prob_excessive + prob_unacceptable
      cbind(
        underdosing = prob_underdosing,
        target = prob_target,
        excessive = prob_excessive,
        unacceptable = prob_unacceptable
      )
    }

    posterior_loss <- as.vector(nextBest@losses %*% t(prob_mat))
    names(posterior_loss) <- data@doseGrid

    probs <- cbind(
      dose = data@doseGrid,
      prob_mat = prob_mat,
      mean = prob_mean,
      std_dev = prob_sd,
      posterior_loss = posterior_loss
    )

    # Eligible grid doses after accounting for maximum possible dose and discarding overdoses.
    is_dose_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo,
      levels = TRUE
    ) &
      (prob_overdose < nextBest@max_overdose_prob)

    # Next best dose is the dose with the minimum loss function.
    next_dose <- if (any(is_dose_eligible)) {
      next_best_level <- which.min(posterior_loss[is_dose_eligible])
      data@doseGrid[is_dose_eligible][next_best_level]
    } else {
      NA_real_
    }

    # Build plot.
    p <- h_next_best_ncrm_loss_plot(
      prob_mat = prob_mat,
      posterior_loss = posterior_loss,
      max_overdose_prob = nextBest@max_overdose_prob,
      dose_grid = data@doseGrid,
      max_eligible_dose_level = sum(is_dose_eligible),
      doselimit = doselimit,
      next_dose = next_dose,
      is_unacceptable_specified = is_unacceptable_specified
    )

    c(list(value = next_dose, probs = probs), p)
  }
)

## NextBestThreePlusThree ----

#' @describeIn nextBest find the next best dose based on the 3+3 method.
#'
#' @aliases nextBest-NextBestThreePlusThree
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestThreePlusThree.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestThreePlusThree",
    doselimit = "missing",
    samples = "missing",
    model = "missing",
    data = "Data"
  ),
  definition = function(nextBest, doselimit, samples, model, data, ...) {
    # The last dose level tested (not necessarily the maximum one).
    last_level <- tail(data@xLevel, 1L)

    # Get number of patients per grid's dose and DLT rate at the last level.
    nPatients <- table(factor(data@x, levels = data@doseGrid))
    n_dlts_last_level <- sum(data@y[data@xLevel == last_level])
    dlt_rate_last_level <- n_dlts_last_level / nPatients[last_level]

    level_change <- if (dlt_rate_last_level < 1 / 3) {
      # Escalate it, unless this is the highest level or the higher dose was already tried.
      ifelse(
        (last_level == data@nGrid) || (nPatients[last_level + 1L] > 0),
        0L,
        1L
      )
    } else {
      # Rate is too high, deescalate it, unless an edge case of 1/3, where the decision
      # depends on the num. of patients: if >3, then deescalate it, otherwise stay.
      ifelse(
        (dlt_rate_last_level == 1 / 3) && (nPatients[last_level] <= 3L),
        0L,
        -1L
      )
    }
    next_dose_level <- last_level + level_change

    # Do we stop here? Only if we have no MTD, or the next level has been tried
    # enough (more than three patients already).
    if (next_dose_level == 0L) {
      next_dose <- NA
      stop_here <- TRUE
    } else {
      next_dose <- data@doseGrid[next_dose_level]
      stop_here <- nPatients[next_dose_level] > 3L
    }

    list(value = next_dose, stopHere = stop_here)
  }
)

## NextBestDualEndpoint ----

#' @describeIn nextBest find the next best dose based on the dual endpoint
#'   model. The additional list element `probs` contains the target and
#'   overdosing probabilities (across all doses in the dose grid) used in the
#'   derivation of the next best dose.
#'
#' @aliases nextBest-NextBestDualEndpoint
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestDualEndpoint.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestDualEndpoint",
    doselimit = "numeric",
    samples = "Samples",
    model = "DualEndpoint",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Biomarker samples at the dose grid points.
    biom_samples <- samples@data$betaW

    prob_target <- if (nextBest@target_relative) {
      # If 'Emax' parameter available, target biomarker level will be relative to 'Emax',
      # otherwise, it will be relative to the maximum biomarker level achieved
      # in dose range for a given sample.
      if ("Emax" %in% names(samples)) {
        lwr <- nextBest@target[1] * samples@data$Emax
        upr <- nextBest@target[2] * samples@data$Emax
        colMeans(apply(biom_samples, 2L, function(s) (s >= lwr) & (s <= upr)))
      } else {
        target_levels <- apply(biom_samples, 1L, function(x) {
          rng <- range(x)
          min(which(h_in_range(
            x,
            nextBest@target * diff(rng) + rng[1] + c(0, 1e-10),
            bounds_closed = c(FALSE, TRUE)
          )))
        })
        prob_target <- as.vector(table(factor(
          target_levels,
          levels = 1:data@nGrid
        )))
        prob_target / nrow(biom_samples)
      }
    } else {
      colMeans(h_in_range(biom_samples, nextBest@target))
    }

    # Now, compute probabilities to be in overdose tox interval, then flag
    # eligible grid doses after accounting for maximum possible dose and discarding overdoses.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples
    )
    prob_overdose <- colMeans(h_in_range(
      prob_samples,
      nextBest@overdose,
      bounds_closed = c(FALSE, TRUE)
    ))

    is_dose_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo,
      levels = TRUE
    ) &
      (prob_overdose < nextBest@max_overdose_prob)

    next_dose <- if (any(is_dose_eligible)) {
      # If maximum target probability is higher the threshold, then take that
      # level, otherwise stick to the maximum level that is eligible.
      # next_dose_level is relative to eligible doses.
      next_dose_level <- ifelse(
        test = any(prob_target[is_dose_eligible] > nextBest@target_thresh),
        yes = which.max(prob_target[is_dose_eligible]),
        no = sum(is_dose_eligible)
      )
      data@doseGrid[is_dose_eligible][next_dose_level]
    } else {
      NA_real_
    }

    # Build plots, first for the target probability.
    p1 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_target * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "darkgreen",
        fill = "darkgreen"
      ) +
      ylim(c(0, 100)) +
      ylab(paste("Target probability [%]"))

    if (is.finite(doselimit)) {
      p1 <- p1 +
        geom_vline(xintercept = doselimit, lwd = 1.1, lty = 2, colour = "black")
    }

    if (any(is_dose_eligible)) {
      p1 <- p1 +
        geom_vline(
          xintercept = data@doseGrid[sum(is_dose_eligible)],
          lwd = 1.1,
          lty = 2,
          colour = "red"
        ) +
        geom_point(
          data = data.frame(
            x = next_dose,
            y = prob_target[is_dose_eligible][next_dose_level] * 100 + 0.03
          ),
          aes(x = x, y = y),
          size = 3,
          pch = 25,
          col = "red",
          bg = "red"
        )
    }

    # Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_overdose * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      geom_hline(
        yintercept = nextBest@max_overdose_prob * 100,
        lwd = 1.1,
        lty = 2,
        colour = "black"
      ) +
      ylim(c(0, 100)) +
      ylab("Overdose probability [%]")

    # Place them below each other.
    plot_joint <- gridExtra::arrangeGrob(p1, p2, nrow = 2)

    list(
      value = next_dose,
      plot = plot_joint,
      singlePlots = list(plot1 = p1, plot2 = p2),
      probs = cbind(
        dose = data@doseGrid,
        target = prob_target,
        overdose = prob_overdose
      )
    )
  }
)

## NextBestMinDist ----

#' @describeIn nextBest gives the dose which is below the dose limit and has an
#'   estimated DLT probability which is closest to the target dose.
#'
#' @aliases nextBest-NextBestMinDist
#'
#' @export
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMinDist",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples,
      ...
    )
    dlt_prob <- colMeans(prob_samples)

    # Determine the dose with the closest distance.
    dose_target <- data@doseGrid[which.min(abs(dlt_prob - nextBest@target))]

    # Determine next dose.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )
    next_dose_level_eligible <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level_eligible]

    # Create a plot.
    p <- ggplot(
      data = data.frame(x = data@doseGrid, y = dlt_prob),
      aes(.data$x, .data$y),
      fill = "grey50",
      colour = "grey50"
    ) +
      geom_line() +
      geom_point() +
      coord_cartesian(xlim = range(data@doseGrid)) +
      scale_x_continuous(
        labels = as.character(data@doseGrid),
        breaks = data@doseGrid,
        guide = guide_axis(check.overlap = TRUE)
      ) +
      geom_hline(yintercept = nextBest@target, linetype = "dotted") +
      geom_vline(xintercept = dose_target, colour = "black", lwd = 1.1) +
      geom_text(
        data = data.frame(x = dose_target),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = 0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("Dose") +
      ylab("Posterior toxicity probability")

    if (is.finite(doselimit)) {
      p <- p +
        geom_vline(xintercept = doselimit, colour = "red", lwd = 1.1) +
        geom_text(
          data = data.frame(x = doselimit),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -0.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(xintercept = next_dose, colour = "blue", lwd = 1.1) +
      geom_text(
        data = data.frame(x = next_dose),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -1.5,
        colour = "blue",
        angle = 90
      )

    list(
      value = next_dose,
      probs = cbind(dose = data@doseGrid, dlt_prob = dlt_prob),
      plot = p
    )
  }
)

## NextBestInfTheory ----

#' @describeIn nextBest gives the appropriate dose within an information
#'   theoretic framework.
#'
#' @aliases nextBest-NextBestInfTheory
#'
#' @export
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestInfTheory",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples,
      ...
    )

    criterion <- colMeans(h_info_theory_dist(
      prob_samples,
      nextBest@target,
      nextBest@asymmetry
    ))

    is_dose_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo,
      levels = TRUE
    )
    doses_eligible <- data@doseGrid[is_dose_eligible]
    next_best_level <- which.min(criterion[is_dose_eligible])
    next_best <- doses_eligible[next_best_level]
    list(value = next_best)
  }
)

## NextBestTD ----

#' @describeIn nextBest find the next best dose based only on the DLT responses
#'   and for [`LogisticIndepBeta`] model class object without DLT samples.
#'
#' @param model (`ModelTox`)\cr the DLT model.
#' @param in_sim (`flag`)\cr is this method used in simulations? Default as `FALSE`.
#'   If this flag is `TRUE` and target dose estimates (during trial and end-of-trial)
#'   are outside of the dose grid range, the information message is printed by
#'   this method.
#'
#' @aliases nextBest-NextBestTD
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestTD.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestTD",
    doselimit = "numeric",
    samples = "missing",
    model = "LogisticIndepBeta",
    data = "Data"
  ),
  definition = function(
    nextBest,
    doselimit = Inf,
    model,
    data,
    in_sim = FALSE,
    ...
  ) {
    assert_flag(in_sim)

    # 'drt' - during the trial, 'eot' end of trial.
    prob_target_drt <- nextBest@prob_target_drt
    prob_target_eot <- nextBest@prob_target_eot

    # Target dose estimates, i.e. the dose with probability of the occurrence of
    # a DLT that equals to the prob_target_drt or prob_target_eot.
    dose_target_drt <- dose(x = prob_target_drt, model, ...)
    dose_target_eot <- dose(x = prob_target_eot, model, ...)

    # Find the next best doses in the doseGrid. The next best dose is the dose
    # at level closest and below the target dose estimate.
    # h_find_interval assumes that elements in doses_eligible are strictly increasing.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )

    next_dose_lev_drt <- h_find_interval(dose_target_drt, doses_eligible)
    next_dose_drt <- doses_eligible[next_dose_lev_drt]

    next_dose_lev_eot <- h_find_interval(dose_target_eot, doses_eligible)
    next_dose_eot <- doses_eligible[next_dose_lev_eot]

    # Find the variance of the log of the dose_target_eot.
    mat <- matrix(
      c(
        -1 / (model@phi2),
        -(log(prob_target_eot / (1 - prob_target_eot)) - model@phi1) /
          (model@phi2)^2
      ),
      nrow = 1
    )
    var_dose_target_eot <- as.vector(mat %*% model@Pcov %*% t(mat))

    # 95% credibility interval.
    ci_dose_target_eot <- exp(
      log(dose_target_eot) + c(-1, 1) * 1.96 * sqrt(var_dose_target_eot)
    )
    cir_dose_target_eot <- ci_dose_target_eot[2] / ci_dose_target_eot[1]

    # Build plot.
    p <- h_next_best_td_plot(
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      data = data,
      prob_dlt = prob(dose = data@doseGrid, model = model, ...),
      doselimit = doselimit,
      next_dose = next_dose_drt
    )

    if (
      !h_in_range(
        dose_target_drt,
        range = dose_grid_range(data),
        bounds_closed = TRUE
      ) &&
        !in_sim
    ) {
      warning(paste(
        "TD",
        prob_target_drt * 100,
        "=",
        dose_target_drt,
        "not within dose grid"
      ))
    }
    if (
      !h_in_range(
        dose_target_eot,
        range = dose_grid_range(data),
        bounds_closed = TRUE
      ) &&
        !in_sim
    ) {
      warning(paste(
        "TD",
        prob_target_eot * 100,
        "=",
        dose_target_eot,
        "not within dose grid"
      ))
    }

    list(
      next_dose_drt = next_dose_drt,
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_eot = next_dose_eot,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      ci_dose_target_eot = ci_dose_target_eot,
      ci_ratio_dose_target_eot = cir_dose_target_eot,
      plot = p
    )
  }
)

## NextBestTDsamples ----

#' @describeIn nextBest find the next best dose based only on the DLT responses
#'   and for [`LogisticIndepBeta`] model class object involving DLT samples.
#'
#' @aliases nextBest-NextBestTDsamples
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestTDsamples.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestTDsamples",
    doselimit = "numeric",
    samples = "Samples",
    model = "LogisticIndepBeta",
    data = "Data"
  ),
  definition = function(
    nextBest,
    doselimit = Inf,
    samples,
    model,
    data,
    in_sim,
    ...
  ) {
    # Generate target dose samples, i.e. the doses with probability of the
    # occurrence of a DLT that equals to the nextBest@prob_target_drt
    # (or nextBest@prob_target_eot, respectively).
    dose_target_drt_samples <- dose(
      x = nextBest@prob_target_drt,
      model,
      samples,
      ...
    )
    dose_target_eot_samples <- dose(
      x = nextBest@prob_target_eot,
      model,
      samples,
      ...
    )

    # Derive the prior/posterior estimates based on two above samples.
    dose_target_drt <- nextBest@derive(dose_target_drt_samples)
    dose_target_eot <- nextBest@derive(dose_target_eot_samples)

    # Find the next doses in the doseGrid. The next dose is the dose at level
    # closest and below the dose_target_drt (or dose_target_eot, respectively).
    # h_find_interval assumes that elements in doses_eligible are strictly increasing.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )

    next_dose_lev_drt <- h_find_interval(dose_target_drt, doses_eligible)
    next_dose_drt <- doses_eligible[next_dose_lev_drt]

    next_dose_lev_eot <- h_find_interval(dose_target_eot, doses_eligible)
    next_dose_eot <- doses_eligible[next_dose_lev_eot]

    # 95% credibility interval.
    ci_dose_target_eot <- as.numeric(quantile(
      dose_target_eot_samples,
      probs = c(0.025, 0.975)
    ))
    cir_dose_target_eot <- ci_dose_target_eot[2] / ci_dose_target_eot[1]

    # Build plot.
    p <- h_next_best_tdsamples_plot(
      dose_target_drt_samples = dose_target_drt_samples,
      dose_target_eot_samples = dose_target_eot_samples,
      dose_target_drt = dose_target_drt,
      dose_target_eot = dose_target_eot,
      dose_grid_range = range(data@doseGrid),
      nextBest = nextBest,
      doselimit = doselimit,
      next_dose = next_dose_drt
    )

    list(
      next_dose_drt = next_dose_drt,
      prob_target_drt = nextBest@prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_eot = next_dose_eot,
      prob_target_eot = nextBest@prob_target_eot,
      dose_target_eot = dose_target_eot,
      ci_dose_target_eot = ci_dose_target_eot,
      ci_ratio_dose_target_eot = cir_dose_target_eot,
      plot = p
    )
  }
)

## NextBestMaxGain ----

#' @describeIn nextBest find the next best dose based only on pseudo DLT model
#'   [`ModelTox`] and [`Effloglog`] efficacy model without samples.
#'
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog`)\cr the efficacy model.
#' @param in_sim (`flag`)\cr is this method used in simulations? Default as `FALSE`.
#'   If this flag is `TRUE` and target dose estimates (during trial and end-of-trial)
#'   are outside of the dose grid range, the information message is printed by
#'   this method.
#'
#' @aliases nextBest-NextBestMaxGain
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestMaxGain.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMaxGain",
    doselimit = "numeric",
    samples = "missing",
    model = "ModelTox",
    data = "DataDual"
  ),
  definition = function(
    nextBest,
    doselimit = Inf,
    model,
    data,
    model_eff,
    in_sim = FALSE,
    ...
  ) {
    assert_class(model_eff, "Effloglog")
    assert_flag(in_sim)

    # 'drt' - during the trial, 'eot' end of trial.
    prob_target_drt <- nextBest@prob_target_drt
    prob_target_eot <- nextBest@prob_target_eot

    # Target dose estimates, i.e. the dose with probability of the occurrence of
    # a DLT that equals to the prob_target_drt or prob_target_eot.
    dose_target_drt <- dose(x = prob_target_drt, model, ...)
    dose_target_eot <- dose(x = prob_target_eot, model, ...)

    # Find the dose which gives the maximum gain.
    dosegrid_range <- dose_grid_range(data)
    opt <- optim(
      par = dosegrid_range[1],
      fn = function(DOSE) {
        -gain(DOSE, model_dle = model, model_eff = model_eff, ...)
      },
      method = "L-BFGS-B",
      lower = dosegrid_range[1],
      upper = dosegrid_range[2]
    )
    dose_mg <- opt$par # this is G*. # no lintr
    max_gain <- -opt$value

    # Print info message if dose target is outside of the range.
    if (
      !h_in_range(
        dose_target_drt,
        range = dose_grid_range(data),
        bounds_closed = FALSE
      ) &&
        !in_sim
    ) {
      print(paste(
        "Estimated TD",
        prob_target_drt * 100,
        "=",
        dose_target_drt,
        "not within dose grid"
      ))
    }
    if (
      !h_in_range(
        dose_target_eot,
        range = dose_grid_range(data),
        bounds_closed = FALSE
      ) &&
        !in_sim
    ) {
      print(paste(
        "Estimated TD",
        prob_target_eot * 100,
        "=",
        dose_target_eot,
        "not within dose grid"
      ))
    }
    if (
      !h_in_range(
        dose_mg,
        range = dose_grid_range(data),
        bounds_closed = FALSE
      ) &&
        !in_sim
    ) {
      print(paste("Estimated max gain dose =", dose_mg, "not within dose grid"))
    }

    # Get closest grid doses for a given target doses.
    nb_doses_at_grid <- h_next_best_mg_doses_at_grid(
      dose_target_drt = dose_target_drt,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      dose_grid = data@doseGrid,
      doselimit = doselimit,
      placebo = data@placebo
    )

    # 95% credibility intervals and corresponding ratios for maximum gain dose and target dose eot.
    ci <- h_next_best_mg_ci(
      dose_target = dose_target_eot,
      dose_mg = dose_mg,
      prob_target = prob_target_eot,
      placebo = data@placebo,
      model = model,
      model_eff = model_eff
    )

    # Build plot.
    p <- h_next_best_mg_plot(
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      max_gain = max_gain,
      next_dose = nb_doses_at_grid$next_dose,
      doselimit = doselimit,
      data = data,
      model = model,
      model_eff = model_eff
    )

    list(
      next_dose = nb_doses_at_grid$next_dose,
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_drt = nb_doses_at_grid$next_dose_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      next_dose_eot = nb_doses_at_grid$next_dose_eot,
      dose_max_gain = dose_mg,
      next_dose_max_gain = nb_doses_at_grid$next_dose_mg,
      ci_dose_target_eot = ci$ci_dose_target,
      ci_ratio_dose_target_eot = ci$ci_ratio_dose_target,
      ci_dose_max_gain = ci$ci_dose_mg,
      ci_ratio_dose_max_gain = ci$ci_ratio_dose_mg,
      plot = p
    )
  }
)

## NextBestMaxGainSamples ----

#' @describeIn nextBest find the next best dose based on DLT and efficacy
#'   responses with DLT and efficacy samples.
#'
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog` or `EffFlexi`)\cr the efficacy model.
#' @param samples_eff (`Samples`)\cr posterior samples from `model_eff` parameters
#'   given `data`.
#' @param in_sim (`flag`)\cr is this method used in simulations? Default as `FALSE`.
#'   If this flag is `TRUE` and target dose estimates (during trial and end-of-trial)
#'   are outside of the dose grid range, the information message is printed by
#'   this method.
#'
#' @aliases nextBest-NextBestMaxGainSamples
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestMaxGainSamples.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMaxGainSamples",
    doselimit = "numeric",
    samples = "Samples",
    model = "ModelTox",
    data = "DataDual"
  ),
  definition = function(
    nextBest,
    doselimit = Inf,
    samples,
    model,
    data,
    model_eff,
    samples_eff,
    in_sim = FALSE,
    ...
  ) {
    assert_true(
      test_class(model_eff, "Effloglog") || test_class(model_eff, "EffFlexi")
    )
    assert_class(samples_eff, "Samples")
    assert_flag(in_sim)

    # 'drt' - during the trial, 'eot' end of trial.
    prob_target_drt <- nextBest@prob_target_drt
    prob_target_eot <- nextBest@prob_target_eot

    # Generate target dose samples, i.e. the doses with probability of the
    # occurrence of a DLT that equals to the prob_target_drt or prob_target_eot.
    dose_target_drt_samples <- dose(
      x = prob_target_drt,
      model,
      samples = samples,
      ...
    )
    dose_target_eot_samples <- dose(
      x = prob_target_eot,
      model,
      samples = samples,
      ...
    )

    # Derive the prior/posterior estimates based on two above samples.
    dose_target_drt <- nextBest@derive(dose_target_drt_samples)
    dose_target_eot <- nextBest@derive(dose_target_eot_samples)

    # Gain samples.
    gain_samples <- sapply(
      data@doseGrid,
      gain,
      model,
      samples,
      model_eff,
      samples_eff,
      ...
    )
    # For every sample, get the dose (from the dose grid) that gives the maximum gain value.
    dose_lev_mg_samples <- apply(gain_samples, 1, which.max)
    dose_mg_samples <- data@doseGrid[dose_lev_mg_samples]
    # Maximum gain dose estimate is the nth percentile of the maximum gain dose samples.
    dose_mg <- nextBest@mg_derive(dose_mg_samples)
    gain_values <- apply(gain_samples, 2, FUN = nextBest@mg_derive)

    # Print info message if dose target is outside of the range.
    dosegrid_range <- dose_grid_range(data)
    if (
      !h_in_range(
        dose_target_drt,
        range = dosegrid_range,
        bounds_closed = FALSE
      ) &&
        !in_sim
    ) {
      print(paste(
        "Estimated TD",
        prob_target_drt * 100,
        "=",
        dose_target_drt,
        "not within dose grid"
      ))
    }
    if (
      !h_in_range(
        dose_target_eot,
        range = dosegrid_range,
        bounds_closed = FALSE
      ) &&
        !in_sim
    ) {
      print(paste(
        "Estimated TD",
        prob_target_eot * 100,
        "=",
        dose_target_eot,
        "not within dose grid"
      ))
    }
    if (
      !h_in_range(dose_mg, range = dosegrid_range, bounds_closed = FALSE) &&
        !in_sim
    ) {
      print(paste("Estimated max gain dose =", dose_mg, "not within dose grid"))
    }

    # Get closest grid doses for a given target doses.
    nb_doses_at_grid <- h_next_best_mg_doses_at_grid(
      dose_target_drt = dose_target_drt,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      dose_grid = data@doseGrid,
      doselimit = doselimit,
      placebo = data@placebo
    )

    # 95% credibility intervals and corresponding ratios for maximum gain dose and target dose eot.
    ci_dose_mg <- as.numeric(quantile(dose_mg_samples, probs = c(0.025, 0.975)))
    cir_dose_mg <- ci_dose_mg[2] / ci_dose_mg[1]

    ci_dose_target_eot <- as.numeric(quantile(
      dose_target_eot,
      probs = c(0.025, 0.975)
    ))
    cir_dose_target_eot <- ci_dose_target_eot[2] / ci_dose_target_eot[1]

    # Build plot.
    p <- h_next_best_mgsamples_plot(
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      dose_mg_samples = dose_mg_samples,
      next_dose = nb_doses_at_grid$next_dose,
      doselimit = doselimit,
      dose_grid_range = dosegrid_range
    )

    list(
      next_dose = nb_doses_at_grid$next_dose,
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_drt = nb_doses_at_grid$next_dose_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      next_dose_eot = nb_doses_at_grid$next_dose_eot,
      dose_max_gain = dose_mg,
      next_dose_max_gain = nb_doses_at_grid$next_dose_mg,
      ci_dose_target_eot = ci_dose_target_eot,
      ci_ratio_dose_target_eot = cir_dose_target_eot,
      ci_dose_max_gain = ci_dose_mg,
      ci_ratio_dose_max_gain = cir_dose_mg,
      plot = p
    )
  }
)

## NextBestProbMTDLTE ----

#' @describeIn nextBest find the next best dose based with the highest
#'  probability of having a toxicity rate less or equal to the target toxicity
#'  level.
#'
#' @aliases nextBest-NextBestProbMTDLTE
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestProbMTDLTE.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestProbMTDLTE",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples,
      ...
    )

    # Determine the maximum dose level with a toxicity probability below or
    # equal to the target and calculate how often a dose is selected as MTD
    # across iterations.
    # The first element of the vector is the relative frequency that no
    # dose in the grid is below or equal to the target, the
    # second element that the 1st dose of the grid is the MTD, etc..
    prob_mtd_lte <- prop.table(
      table(factor(
        rowSums(prob_samples <= nextBest@target),
        levels = 0:data@nGrid
      ))
    )

    allocation_crit <- as.vector(prob_mtd_lte)
    names(allocation_crit) <- as.character(c(0, data@doseGrid))

    # In case that placebo is used, placebo and the portion that is not assigned
    # to any dose of the grid are merged.
    if (data@placebo) {
      allocation_crit[1] <- sum(allocation_crit[1:2])
      allocation_crit <- allocation_crit[-2]
    }

    # Handling of the portion that is not assigned to an active dose of
    # the dose grid. The portion is added to the minimum active dose
    # of the dose grid.
    allocation_crit[2] <- sum(allocation_crit[1:2])
    allocation_crit <- allocation_crit[-1]

    # Determine the dose with the highest relative frequency.
    allocation_crit_dose <- as.numeric(names(allocation_crit))
    dose_target <- allocation_crit_dose[which.max(allocation_crit)]

    # Determine next dose.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )
    next_dose_level_eligible <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level_eligible]

    # Create a plot.
    plt_data <- if (data@placebo && (data@doseGrid[1] == next_dose)) {
      data.frame(
        x = as.factor(data@doseGrid),
        y = c(0, as.numeric(allocation_crit)) * 100
      )
    } else {
      data.frame(
        x = as.factor(allocation_crit_dose),
        y = as.numeric(allocation_crit) * 100
      )
    }

    p <- ggplot(
      data = plt_data,
      fill = "grey50",
      colour = "grey50"
    ) +
      geom_col(aes(x, y), fill = "grey75") +
      scale_x_discrete(drop = FALSE, guide = guide_axis(check.overlap = TRUE)) +
      geom_vline(
        xintercept = as.factor(dose_target),
        lwd = 1.1,
        colour = "black"
      ) +
      geom_text(
        data = data.frame(x = as.factor(dose_target)),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = -0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("Dose") +
      ylab(paste("Allocation criterion [%]"))

    if (is.finite(doselimit)) {
      doselimit_level <- if (sum(allocation_crit_dose == doselimit) > 0) {
        which(allocation_crit_dose == doselimit)
      } else {
        ifelse(
          test = data@placebo && (data@doseGrid[1] == next_dose),
          yes = 1.5,
          no = sum(allocation_crit_dose < doselimit) + 0.5
        )
      }

      p <- p +
        geom_vline(
          xintercept = doselimit_level,
          colour = "red",
          lwd = 1.1
        ) +
        geom_text(
          data = data.frame(x = doselimit_level),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -1.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(
        xintercept = as.factor(next_dose),
        colour = "blue",
        lwd = 1.1
      ) +
      geom_text(
        data = data.frame(x = as.factor(next_dose)),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -2.5,
        colour = "blue",
        angle = 90
      )

    list(
      value = next_dose,
      allocation = cbind(
        dose = allocation_crit_dose,
        allocation = allocation_crit
      ),
      plot = p
    )
  }
)

## NextBestProbMTDMinDist ----

#' @describeIn nextBest find the next best dose based with the highest
#'  probability of having a toxicity rate with minimum distance to the
#'  target toxicity level.
#'
#' @aliases nextBest-NextBestProbMTDMinDist
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestProbMtdMinDist.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestProbMTDMinDist",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(
      data@doseGrid,
      prob,
      model = model,
      samples = samples,
      ...
    )

    # Determine which dose level has the minimum distance to target.
    dose_min_mtd_dist <- apply(
      prob_samples,
      1,
      function(x) which.min(abs(x - nextBest@target))
    )

    allocation_crit <- prop.table(
      table(factor(dose_min_mtd_dist, levels = 1:data@nGrid))
    )
    names(allocation_crit) <- as.character(data@doseGrid)

    # In case that placebo is used, placebo and the first non-placebo dose
    # of the grid are merged.
    if (data@placebo) {
      allocation_crit[2] <- sum(allocation_crit[1:2])
      allocation_crit <- allocation_crit[-1]
    }

    # Determine the dose with the highest relative frequency.
    allocation_crit_dose <- as.numeric(names(allocation_crit))
    dose_target <- allocation_crit_dose[which.max(allocation_crit)]

    # Determine next dose.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )
    next_dose_level_eligible <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level_eligible]

    # Create a plot.
    plt_data <- if (data@placebo && data@doseGrid[1] == next_dose) {
      data.frame(
        x = as.factor(data@doseGrid),
        y = c(0, as.numeric(allocation_crit)) * 100
      )
    } else {
      data.frame(
        x = as.factor(allocation_crit_dose),
        y = as.numeric(allocation_crit) * 100
      )
    }

    p <- ggplot(
      data = plt_data,
      fill = "grey50",
      colour = "grey50"
    ) +
      geom_col(aes(x, y), fill = "grey75") +
      scale_x_discrete(guide = guide_axis(check.overlap = TRUE)) +
      geom_vline(
        xintercept = as.factor(dose_target),
        lwd = 1.1,
        colour = "black"
      ) +
      geom_text(
        data = data.frame(x = as.factor(dose_target)),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = -0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("Dose") +
      ylab(paste("Allocation criterion [%]"))

    if (is.finite(doselimit)) {
      doselimit_level <- if (any(allocation_crit_dose == doselimit)) {
        which(allocation_crit_dose == doselimit)
      } else {
        ifelse(
          test = data@placebo && data@doseGrid[1] == next_dose,
          yes = 1.5,
          no = sum(allocation_crit_dose < doselimit) + 0.5
        )
      }

      p <- p +
        geom_vline(
          xintercept = doselimit_level,
          colour = "red",
          lwd = 1.1
        ) +
        geom_text(
          data = data.frame(x = doselimit_level),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -1.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(
        xintercept = as.factor(next_dose),
        colour = "blue",
        lwd = 1.1
      ) +
      geom_text(
        data = data.frame(x = as.factor(next_dose)),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -2.5,
        colour = "blue",
        angle = 90
      )

    list(
      value = next_dose,
      allocation = cbind(
        dose = allocation_crit_dose,
        allocation = allocation_crit
      ),
      plot = p
    )
  }
)

## NextBestOrdinal ----

#' @describeIn nextBest find the next best dose for ordinal CRM models.
#'
#' @aliases nextBest-NextBestOrdinal
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestOrdinal.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestOrdinal",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    stop(
      paste0(
        "NextBestOrdinal objects can only be used with LogisticLogNormalOrdinal ",
        "models and DataOrdinal data objects. In this case, the model is a '",
        class(model),
        "' object and the data is in a ",
        class(data),
        " object."
      )
    )
  }
)

#' @describeIn nextBest find the next best dose for ordinal CRM models.
#'
#' @aliases nextBest-NextBestOrdinal
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestOrdinal.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestOrdinal",
    doselimit = "numeric",
    samples = "Samples",
    model = "LogisticLogNormalOrdinal",
    data = "DataOrdinal"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    nextBest(
      nextBest = nextBest@rule,
      doselimit = doselimit,
      samples = h_convert_ordinal_samples(samples, nextBest@grade),
      model = h_convert_ordinal_model(model, nextBest@grade),
      data = h_convert_ordinal_data(data, nextBest@grade),
      ...
    )
  }
)

# maxDose ----

## generic ----

#' Determine the Maximum Possible Next Dose
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function determines the upper limit of the next dose based on the
#' `increments`and the `data`.
#'
#' @param increments (`Increments`)\cr the rule for the next best dose.
#' @param data (`Data`)\cr input data.
#' @param ... additional arguments without method dispatch.
#'
#' @return A `number`, the maximum possible next dose.
#'
#' @export
#'
setGeneric(
  name = "maxDose",
  def = function(increments, data, ...) {
    standardGeneric("maxDose")
  },
  valueClass = "numeric"
)

## IncrementsRelative ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments.
#'
#' @aliases maxDose-IncrementsRelative
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelative.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelative",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    last_dose <- data@x[data@nObs]
    # Determine in which interval the `last_dose` is.
    assert_true(last_dose >= head(increments@intervals, 1))
    last_dose_interval <- findInterval(
      x = last_dose,
      vec = increments@intervals
    )
    (1 + increments@increments[last_dose_interval]) * last_dose
  }
)

## IncrementsRelativeDLT ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments determined by DLTs so far.
#'
#' @aliases maxDose-IncrementsRelativeDLT
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelativeDLT.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelativeDLT",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    dlt_count <- sum(data@y)
    # Determine in which interval the `dlt_count` is.
    assert_true(dlt_count >= increments@intervals[1])
    dlt_count_interval <- findInterval(
      x = dlt_count,
      vec = increments@intervals
    )
    (1 + increments@increments[dlt_count_interval]) * data@x[data@nObs]
  }
)

## IncrementsRelativeDLTCurrent ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments determined by DLTs in the current cohort.
#'
#' @aliases maxDose-IncrementsRelativeDLTCurrent
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelativeDLTCurrent.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelativeDLTCurrent",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    last_dose <- data@x[data@nObs]

    # Determine how many DLTs have occurred in the last cohort.
    last_cohort <- data@cohort[data@nObs]
    last_cohort_indices <- which(data@cohort == last_cohort)
    dlt_count_lcohort <- sum(data@y[last_cohort_indices])

    # Determine in which interval the `dlt_count_lcohort` is.
    assert_true(dlt_count_lcohort >= increments@intervals[1])
    dlt_count_lcohort_int <- findInterval(
      x = dlt_count_lcohort,
      vec = increments@intervals
    )
    (1 + increments@increments[dlt_count_lcohort_int]) * last_dose
  }
)

## IncrementsRelativeParts ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments as well as part 1 and beginning of part 2.
#'
#' @aliases maxDose-IncrementsRelativeParts
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelativeParts.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelativeParts",
    data = "DataParts"
  ),
  definition = function(increments, data, ...) {
    all_in_part1 <- all(data@part == 1L)
    incrmnt <- if (all_in_part1) {
      part2_started <- data@nextPart == 2L
      if (part2_started) {
        any_dlt <- any(data@y == 1L)
        if (any_dlt) {
          increments@dlt_start
        } else if (increments@clean_start <= 0L) {
          increments@clean_start
        }
      } else {
        1L
      }
    }

    if (is.null(incrmnt)) {
      callNextMethod(increments, data, ...)
    } else {
      max_dose_lev_part1 <- match_within_tolerance(
        max(data@x),
        data@part1Ladder
      )
      new_max_dose_level <- max_dose_lev_part1 + incrmnt
      assert_true(new_max_dose_level >= 0L)
      assert_true(new_max_dose_level <= length(data@part1Ladder))
      data@part1Ladder[new_max_dose_level]
    }
  }
)

## IncrementsDoseLevels ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   the number of dose grid levels. That is, the max dose is determined as
#'   the one which level is equal to: base dose level + level increment.
#'   The base dose level is the level of the last dose in grid or the level
#'   of the maximum dose applied, which is defined in `increments` object.
#'   Find out more in [`IncrementsDoseLevels`].
#'
#' @aliases maxDose-IncrementsDoseLevels
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsDoseLevels.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsDoseLevels",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    # Determine what is the basis level for increment,
    # i.e. the last dose or the max dose applied.
    basis_dose_level <- ifelse(
      increments@basis_level == "last",
      data@xLevel[data@nObs],
      max(data@xLevel)
    )
    max_dose_level <- min(basis_dose_level + increments@levels, data@nGrid)
    data@doseGrid[max_dose_level]
  }
)

## IncrementsHSRBeta ----

#' @describeIn maxDose determine the maximum possible next dose for escalation.
#'
#' @aliases maxDose-IncrementsHSRBeta
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsHSRBeta.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsHSRBeta",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    # Summary of observed data per dose level.
    y <- factor(data@y, levels = c("0", "1"))
    dlt_tab <- table(y, data@x)

    # Ignore placebo if applied.
    if (data@placebo == TRUE & min(data@x) == data@doseGrid[1]) {
      dlt_tab <- dlt_tab[, -1]
    }

    # Extract dose names as these get lost if only one dose available.
    non_plcb_doses <- unique(sort(as.numeric(colnames(dlt_tab))))

    # Toxicity probability per dose level.
    x <- dlt_tab[2, ]
    n <- apply(dlt_tab, 2, sum)
    tox_prob <- pbeta(
      increments@target,
      x + increments@a,
      n - x + increments@b,
      lower.tail = FALSE
    )

    # Return the min toxic dose level or maximum dose level if no dose is toxic,
    # while ignoring placebo.
    dose_tox <- if (sum(tox_prob > increments@prob) > 0) {
      min(non_plcb_doses[which(tox_prob > increments@prob)])
    } else {
      # Add small value to max dose, so that the max dose is always smaller.
      max(data@doseGrid) + 0.01
    }

    # Determine the next maximum possible dose.
    # In case that the first active dose is above probability threshold,
    # the first active dose is reported as maximum. I.e. in case that placebo is used,
    # the second dose is reported. Please note that this rule should be used together
    # with the hard safety stopping rule to avoid inconsistent results.
    max(
      data@doseGrid[data@doseGrid < dose_tox],
      data@doseGrid[data@placebo + 1]
    )
  }
)

## IncrementsMin ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   multiple increment rules, taking the minimum across individual increments.
#'
#' @aliases maxDose-IncrementsMin
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsMin.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsMin",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    individual_results <- sapply(
      increments@increments_list,
      maxDose,
      data = data,
      ...
    )
    min(individual_results)
  }
)

#' @describeIn maxDose determine the maximum possible next dose based on
#'   multiple increment rules, taking the minimum across individual increments.
#'
#' @aliases maxDose-IncrementsMin
#'
#' @export
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsMin",
    data = "DataOrdinal"
  ),
  definition = function(increments, data, ...) {
    individual_results <- sapply(
      increments@increments_list,
      maxDose,
      data = data,
      ...
    )
    min(individual_results)
  }
)

## IncrementsOrdinal ----

#' @describeIn maxDose determine the maximum possible next dose in an ordinal
#' CRM trial
#'
#' @aliases maxDose-IncrementsOrdinal
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsOrdinal.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsOrdinal",
    data = "DataOrdinal"
  ),
  definition = function(increments, data, ...) {
    maxDose(
      increments = increments@rule,
      data = h_convert_ordinal_data(
        data,
        increments@grade,
        ...
      )
    )
  }
)

## IncrementsMaxToxProb ----

#' @describeIn maxDose determine the maximum possible next dose based on the
#' probability of toxicity
#' @param model (`GeneralModel`)\cr The model on which probabilities will be based
#' @param samples (`Samples`)\cr The MCMC samples to which `model` will be applied
#'
#' @aliases maxDose-IncrementsMaxToxProb
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsMaxToxProb.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsMaxToxProb",
    data = "DataOrdinal"
  ),
  definition = function(increments, data, model, samples, ...) {
    assert_class(samples, "Samples")
    assert_true(length(increments@prob) == length(data@yCategories) - 1)
    nm <- utils::tail(names(data@yCategories), -1)
    assert_set_equal(names(increments@prob), nm)

    probs <- dplyr::bind_rows(
      lapply(
        seq_along(increments@prob),
        function(g) {
          fitted_probs <- fit(samples, model, data, grade = g, ...)
          safe_fitted_probs <- dplyr::filter(
            fitted_probs,
            middle < increments@prob[nm[g]]
          )
          highest_safe_fitted_prob <- utils::tail(safe_fitted_probs, 1)
        }
      )
    )
    min(probs$dose)
  }
)
#' @describeIn maxDose determine the maximum possible next dose based on the
#' probability of toxicity
#' @param model (`GeneralModel`)\cr The model on which probabilities will be based
#' @param samples (`Samples`)\cr The MCMC samples to which `model` will be applied
#'
#' @aliases maxDose-IncrementsMaxToxProb
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsMaxToxProb.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsMaxToxProb",
    data = "Data"
  ),
  definition = function(increments, data, model, samples, ...) {
    assert_class(samples, "Samples")
    assert_true(length(increments@prob) == 1)

    fitted_prob <- fit(samples, model, data, ...)
    safe_fitted_prob <- dplyr::filter(fitted_prob, middle < increments@prob)
    highest_safe_fitted_prob <- utils::tail(safe_fitted_prob, 1)
    highest_safe_fitted_prob$dose
  }
)

## tidy-IncrementsMaxToxProb ----

#' @rdname tidy
#' @aliases tidy-IncrementsMaxToxProb
#' @example examples/Rules-method-tidyIncrementsMaxToxProb.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsMaxToxProb"),
  definition = function(x, ...) {
    grades <- names(x@prob)
    if (is.null(grades)) {
      grades <- "1"
    }
    tibble(
      Grade = grades,
      Prob = x@prob
    ) %>%
      h_tidy_class(x)
  }
)

# nolint start

## ============================================================

## --------------------------------------------------
## "AND" combination of stopping rules
## --------------------------------------------------

##' The method combining two atomic stopping rules
##'
##' @param e1 First \code{\linkS4class{Stopping}} object
##' @param e2 Second \code{\linkS4class{Stopping}} object
##' @return The \code{\linkS4class{StoppingAll}} object
##'
##' @example examples/Rules-method-and-stopping-stopping.R
##' @keywords methods
setMethod(
  "&",
  signature(
    e1 = "Stopping",
    e2 = "Stopping"
  ),
  def = function(e1, e2) {
    StoppingAll(list(e1, e2))
  }
)

##' The method combining a stopping list and an atomic
##'
##' @param e1 \code{\linkS4class{StoppingAll}} object
##' @param e2 \code{\linkS4class{Stopping}} object
##' @return The modified \code{\linkS4class{StoppingAll}} object
##'
##' @example examples/Rules-method-and-stoppingAll-stopping.R
##' @keywords methods
setMethod(
  "&",
  signature(
    e1 = "StoppingAll",
    e2 = "Stopping"
  ),
  def = function(e1, e2) {
    e1@stop_list <- c(
      e1@stop_list,
      e2
    )
    return(e1)
  }
)

##' The method combining an atomic and a stopping list
##'
##' @param e1 \code{\linkS4class{Stopping}} object
##' @param e2 \code{\linkS4class{StoppingAll}} object
##' @return The modified \code{\linkS4class{StoppingAll}} object
##'
##' @example examples/Rules-method-and-stopping-stoppingAll.R
##' @keywords methods
setMethod(
  "&",
  signature(
    e1 = "Stopping",
    e2 = "StoppingAll"
  ),
  def = function(e1, e2) {
    e2@stop_list <- c(
      e1,
      e2@stop_list
    )
    return(e2)
  }
)

## --------------------------------------------------
## "OR" combination of stopping rules
## --------------------------------------------------

##' The method combining two atomic stopping rules
##'
##' @param e1 First \code{\linkS4class{Stopping}} object
##' @param e2 Second \code{\linkS4class{Stopping}} object
##' @return The \code{\linkS4class{StoppingAny}} object
##'
##' @aliases |,Stopping,Stopping-method
##' @name or-Stopping-Stopping
##' @example examples/Rules-method-or-stopping-stopping.R
##' @keywords methods
setMethod(
  "|",
  signature(
    e1 = "Stopping",
    e2 = "Stopping"
  ),
  def = function(e1, e2) {
    StoppingAny(list(e1, e2))
  }
)

##' The method combining a stopping list and an atomic
##'
##' @param e1 \code{\linkS4class{StoppingAny}} object
##' @param e2 \code{\linkS4class{Stopping}} object
##' @return The modified \code{\linkS4class{StoppingAny}} object
##'
##' @aliases |,StoppingAny,Stopping-method
##' @name or-Stopping-StoppingAny
##' @example examples/Rules-method-or-stoppingAny-stopping.R
##' @keywords methods
setMethod(
  "|",
  signature(
    e1 = "StoppingAny",
    e2 = "Stopping"
  ),
  def = function(e1, e2) {
    e1@stop_list <- c(
      e1@stop_list,
      e2
    )
    return(e1)
  }
)

##' The method combining an atomic and a stopping list
##'
##' @param e1 \code{\linkS4class{Stopping}} object
##' @param e2 \code{\linkS4class{StoppingAny}} object
##' @return The modified \code{\linkS4class{StoppingAny}} object
##'
##' @aliases |,Stopping,StoppingAny-method
##' @name or-StoppingAny-Stopping
##' @example examples/Rules-method-or-stopping-stoppingAny.R
##' @keywords methods
setMethod(
  "|",
  signature(
    e1 = "Stopping",
    e2 = "StoppingAny"
  ),
  def = function(e1, e2) {
    e2@stop_list <- c(
      e1,
      e2@stop_list
    )
    return(e2)
  }
)

# nolint end

# Stopping ----

## generic ----

#' Stop the trial?
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function returns whether to stop the trial.
#'
#' @param stopping (`Stopping`)\cr the rule for stopping the trial.
#' @param dose the recommended next best dose.
#' @param samples (`Samples`)\cr the mcmc samples.
#' @param model (`GeneralModel`)\cr the model.
#' @param data (`Data`)\cr input data.
#' @param ... additional arguments without method dispatch.
#'
#' @return logical value: `TRUE` if the trial can be stopped, `FALSE`
#' otherwise. It should have an attribute `message` which gives the reason
#' for the decision.
#'
#' @export
#' @example examples/Rules-method-CombiningStoppingRulesAndOr.R
setGeneric(
  name = "stopTrial",
  def = function(stopping, dose, samples, model, data, ...) {
    standardGeneric("stopTrial")
  },
  valueClass = "logical"
)

## StoppingMissingDose ----

#' @describeIn stopTrial Stop based on value returned by next best dose.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @aliases stopTrial-StoppingMissingDose
#' @example examples/Rules-method-stopTrial-StoppingMissingDose.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMissingDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    do_stop <- is.na(dose) || (data@placebo && dose == min(data@doseGrid))

    msg <- paste(
      "Next dose is",
      ifelse(
        do_stop,
        paste(
          ifelse(
            data@placebo && dose == min(data@doseGrid),
            "placebo dose",
            "NA"
          ),
          ", i.e., no active dose is safe enough according to the NextBest rule."
        ),
        "available at the dose grid."
      )
    )

    structure(do_stop, message = msg, report_label = stopping@report_label)
  }
)

# nolint start

## --------------------------------------------------
## Stopping based on multiple stopping rules
## --------------------------------------------------

##' @describeIn stopTrial Stop based on multiple stopping rules
##' @example examples/Rules-method-stopTrial-StoppingList.R
setMethod(
  "stopTrial",
  signature = signature(
    stopping = "StoppingList",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  def = function(stopping, dose, samples, model, data, ...) {
    ## evaluate the individual stopping rules
    ## in the list
    individualResults <-
      if (missing(samples)) {
        lapply(
          stopping@stop_list,
          stopTrial,
          dose = dose,
          model = model,
          data = data,
          ...
        )
      } else {
        lapply(
          stopping@stop_list,
          stopTrial,
          dose = dose,
          samples = samples,
          model = model,
          data = data,
          ...
        )
      }

    ## summarize to obtain overall result
    overallResult <- stopping@summary(as.logical(individualResults))

    ## retrieve individual text messages,
    ## but let them in the list structure
    overallText <- lapply(individualResults, attr, "message")

    return(structure(
      overallResult,
      message = overallText,
      individual = individualResults
    ))
  }
)

## --------------------------------------------------
## Stopping based on fulfillment of all multiple stopping rules
## --------------------------------------------------

##' @describeIn stopTrial Stop based on fulfillment of all multiple stopping
##' rules
##'
##' @example examples/Rules-method-stopTrial-StoppingAll.R
setMethod(
  "stopTrial",
  signature = signature(
    stopping = "StoppingAll",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  def = function(stopping, dose, samples, model, data, ...) {
    ## evaluate the individual stopping rules
    ## in the list
    individualResults <-
      if (missing(samples)) {
        lapply(
          stopping@stop_list,
          stopTrial,
          dose = dose,
          model = model,
          data = data,
          ...
        )
      } else {
        lapply(
          stopping@stop_list,
          stopTrial,
          dose = dose,
          samples = samples,
          model = model,
          data = data,
          ...
        )
      }

    ## summarize to obtain overall result
    overallResult <- all(as.logical(individualResults))

    ## retrieve individual text messages,
    ## but let them in the list structure
    overallText <- lapply(individualResults, attr, "message")

    return(structure(
      overallResult,
      message = overallText,
      individual = individualResults,
      report_label = stopping@report_label
    ))
  }
)


## --------------------------------------------------
## Stopping based on fulfillment of any stopping rule
## --------------------------------------------------

##' @describeIn stopTrial Stop based on fulfillment of any stopping rule
##'
##' @example examples/Rules-method-stopTrial-StoppingAny.R
setMethod(
  "stopTrial",
  signature = signature(
    stopping = "StoppingAny",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  def = function(stopping, dose, samples, model, data, ...) {
    ## evaluate the individual stopping rules
    ## in the list
    individualResults <-
      if (missing(samples)) {
        lapply(
          stopping@stop_list,
          stopTrial,
          dose = dose,
          model = model,
          data = data,
          ...
        )
      } else {
        lapply(
          stopping@stop_list,
          stopTrial,
          dose = dose,
          samples = samples,
          model = model,
          data = data,
          ...
        )
      }

    ## summarize to obtain overall result
    overallResult <- any(as.logical(individualResults))

    ## retrieve individual text messages,
    ## but let them in the list structure
    overallText <- lapply(individualResults, attr, "message")

    return(structure(
      overallResult,
      message = overallText,
      individual = individualResults,
      report_label = stopping@report_label
    ))
  }
)


## --------------------------------------------------
## Stopping based on number of cohorts near to next best dose
## --------------------------------------------------

##' @describeIn stopTrial Stop based on number of cohorts near to next best dose
##'
##' @example examples/Rules-method-stopTrial-StoppingCohortsNearDose.R
setMethod(
  "stopTrial",
  signature = signature(
    stopping = "StoppingCohortsNearDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  def = function(stopping, dose, samples, model, data, ...) {
    ## determine the range where the cohorts must lie in
    lower <- (100 - stopping@percentage) / 100 * dose
    upper <- (100 + stopping@percentage) / 100 * dose

    ## which patients lie there?
    indexPatients <- which((data@x >= lower) & (data@x <= upper))

    ## how many cohorts?
    nCohorts <- length(unique(data@cohort[indexPatients]))

    ## so can we stop?
    doStop <- nCohorts >= stopping@nCohorts

    ## generate message
    text <- paste(
      nCohorts,
      " cohorts lie within ",
      stopping@percentage,
      "% of the next best dose ",
      dose,
      ". This ",
      ifelse(doStop, "reached", "is below"),
      " the required ",
      stopping@nCohorts,
      " cohorts",
      sep = ""
    )

    ## return both
    return(structure(
      doStop,
      message = text,
      report_label = stopping@report_label
    ))
  }
)


## -------------------------------------------------------------
## Stopping based on number of patients near to next best dose
## -------------------------------------------------------------

##' @describeIn stopTrial Stop based on number of patients near to next best
##' dose
##'
##' @example examples/Rules-method-stopTrial-StoppingPatientsNearDose.R
setMethod(
  "stopTrial",
  signature = signature(
    stopping = "StoppingPatientsNearDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  def = function(stopping, dose, samples, model, data, ...) {
    ## determine the range where the cohorts must lie in
    lower <- (100 - stopping@percentage) / 100 * dose
    upper <- (100 + stopping@percentage) / 100 * dose

    ## how many patients lie there?
    nPatients <- ifelse(
      is.na(dose),
      0,
      sum((data@x >= lower) & (data@x <= upper))
    )

    ## so can we stop?
    doStop <- nPatients >= stopping@nPatients

    ## generate message
    text <- paste(
      nPatients,
      " patients lie within ",
      stopping@percentage,
      "% of the next best dose ",
      dose,
      ". This ",
      ifelse(doStop, "reached", "is below"),
      " the required ",
      stopping@nPatients,
      " patients",
      sep = ""
    )

    ## return both
    return(structure(
      doStop,
      message = text,
      report_label = stopping@report_label
    ))
  }
)

## --------------------------------------------------
## Stopping based on minimum number of cohorts
## --------------------------------------------------

##' @describeIn stopTrial Stop based on minimum number of cohorts
##'
##' @example examples/Rules-method-stopTrial-StoppingMinCohorts.R
setMethod(
  "stopTrial",
  signature = signature(
    stopping = "StoppingMinCohorts",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  def = function(stopping, dose, samples, model, data, ...) {
    ## determine number of cohorts
    nCohorts <- length(unique(data@cohort))

    ## so can we stop?
    doStop <- nCohorts >= stopping@nCohorts

    ## generate message
    text <-
      paste(
        "Number of cohorts is",
        nCohorts,
        "and thus",
        ifelse(doStop, "reached", "below"),
        "the prespecified minimum number",
        stopping@nCohorts
      )

    ## return both
    return(structure(
      doStop,
      message = text,
      report_label = stopping@report_label
    ))
  }
)

## --------------------------------------------------
## Stopping based on minimum number of patients
## --------------------------------------------------

##' @describeIn stopTrial Stop based on minimum number of patients
##'
##' @example examples/Rules-method-stopTrial-StoppingMinPatients.R
setMethod(
  "stopTrial",
  signature = signature(
    stopping = "StoppingMinPatients",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  def = function(stopping, dose, samples, model, data, ...) {
    ## so can we stop?
    doStop <- data@nObs >= stopping@nPatients

    ## generate message
    text <-
      paste(
        "Number of patients is",
        data@nObs,
        "and thus",
        ifelse(doStop, "reached", "below"),
        "the prespecified minimum number",
        stopping@nPatients
      )

    ## return both
    return(structure(
      doStop,
      message = text,
      report_label = stopping@report_label
    ))
  }
)

# nolint end

## StoppingTargetProb ----

#' @describeIn stopTrial Stop based on probability of target tox interval
#'
#' @aliases stopTrial-StoppingTargetProb
#' @example examples/Rules-method-stopTrial-StoppingTargetProb.R
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingTargetProb",
    dose = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Compute probability to be in target interval.
    prob_target <- ifelse(
      is.na(dose),
      0,
      mean(
        prob(dose = dose, model, samples, ...) >= stopping@target[1] &
          prob(dose = dose, model, samples, ...) <= stopping@target[2]
      )
    )

    do_stop <- prob_target >= stopping@prob

    msg <- paste(
      "Probability for target toxicity is",
      round(prob_target * 100),
      "% for dose",
      dose,
      "and thus",
      ifelse(do_stop, "above", "below"),
      "the required",
      round(stopping@prob * 100),
      "%"
    )

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

# nolint start

## --------------------------------------------------
## Stopping based on MTD distribution
## --------------------------------------------------

##' @describeIn stopTrial Stop based on MTD distribution
##'
##' @example examples/Rules-method-stopTrial-StoppingMTDdistribution.R
setMethod(
  "stopTrial",
  signature = signature(
    stopping = "StoppingMTDdistribution",
    dose = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "ANY"
  ),
  def = function(stopping, dose, samples, model, data, ...) {
    ## First, generate the MTD samples.

    ## add prior data and samples to the
    ## function environment so that they
    ## can be used.
    mtdSamples <- dose(
      x = stopping@target,
      model,
      samples,
      ...
    )

    ## what is the absolute threshold?
    absThresh <- stopping@thresh * dose

    ## what is the probability to be above this dose?
    prob <- ifelse(
      is.na(absThresh),
      0,
      mean(mtdSamples > absThresh)
    )

    ## so can we stop?
    doStop <- prob >= stopping@prob

    ## generate message
    text <-
      paste(
        "Probability of MTD above",
        round(stopping@thresh * 100),
        "% of current dose",
        dose,
        "is",
        round(prob * 100),
        "% and thus",
        ifelse(doStop, "greater than or equal to", "strictly less than"),
        "the required",
        round(stopping@prob * 100),
        "%"
      )

    ## return both
    return(structure(
      doStop,
      message = text,
      report_label = stopping@report_label
    ))
  }
)

# nolint end

## StoppingMTDCV ----

#' @rdname stopTrial
#'
#' @description Stopping rule based precision of the MTD estimation.
#'   The trial is stopped, when the MTD can be estimated with sufficient precision.
#'   The criteria is based on the robust coefficient of variation (CV) calculated
#'   from the posterior distribution.
#'   The robust CV is defined `mad(MTD) / median(MTD)`, where `mad` is the median
#'   absolute deviation.
#'
#' @aliases stopTrial-StoppingMTDCV
#' @example examples/Rules-method-stopTrial-StoppingMTDCV.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMTDCV",
    dose = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    mtd_samples <- dose(
      x = stopping@target,
      model,
      samples,
      ...
    )
    # CV of MTD expressed as percentage, derived based on MTD posterior samples.
    mtd_cv <- (mad(mtd_samples) / median(mtd_samples)) * 100
    do_stop <- mtd_cv <= stopping@thresh_cv

    msg <- paste(
      "CV of MTD is",
      round(mtd_cv),
      "% and thus",
      ifelse(do_stop, "below", "above"),
      "the required precision threshold of",
      round(stopping@thresh_cv),
      "%"
    )

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)


## StoppingLowestDoseHSRBeta ----

#' @rdname stopTrial
#'
#' @description Stopping based based on the lowest non placebo dose. The trial is
#'  stopped when the lowest non placebo dose meets the Hard
#'  Safety Rule, i.e. it is deemed to be overly toxic. Stopping is based on the
#'  observed data at the lowest dose level using a Bin-Beta model
#'  based on DLT probability.
#'
#' @aliases stopTrial-StoppingLowestDoseHSRBeta
#' @example examples/Rules-method-stopTrial-StoppingLowestDoseHSRBeta.R
#' @export
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingLowestDoseHSRBeta",
    dose = "numeric",
    samples = "Samples"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Actual number of patients at first active dose.
    n <- sum(data@x == data@doseGrid[data@placebo + 1])

    # Determine toxicity probability of the first active dose.
    tox_prob_first_dose <-
      if (n > 0) {
        x <- sum(data@y[which(data@x == data@doseGrid[data@placebo + 1])])
        pbeta(
          stopping@target,
          x + stopping@a,
          n - x + stopping@b,
          lower.tail = FALSE
        )
      } else {
        0
      }

    do_stop <- tox_prob_first_dose > stopping@prob

    # generate message
    msg <- if (n == 0) {
      "Lowest active dose not tested, stopping rule not applied."
    } else {
      paste(
        "Probability that the lowest active dose of ",
        data@doseGrid[data@placebo + 1],
        " being toxic based on posterior Beta distribution using a Beta(",
        stopping@a,
        ",",
        stopping@b,
        ") prior is ",
        round(tox_prob_first_dose * 100),
        "% and thus ",
        ifelse(do_stop, "above", "below"),
        " the required ",
        round(stopping@prob * 100),
        "% threshold.",
        sep = ""
      )
    }

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

## StoppingTargetBiomarker ----

#' @describeIn stopTrial Stop based on probability of targeting biomarker
#'
#' @aliases stopTrial-StoppingTargetBiomarker
#' @example examples/Rules-method-stopTrial-StoppingTargetBiomarker.R
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingTargetBiomarker",
    dose = "numeric",
    samples = "Samples",
    model = "DualEndpoint",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Compute the target biomarker prob at this dose.
    # Get the biomarker level samples at the dose grid points.
    biom_level_samples <- biomarker(
      xLevel = seq_len(data@nGrid),
      model,
      samples,
      ...
    )

    # If target is relative to maximum.
    if (stopping@is_relative) {
      # If there is an 'Emax' parameter, target biomarker level will
      # be relative to 'Emax', otherwise will be relative to the
      # maximum biomarker level achieved in the given dose range.
      if ("Emax" %in% names(samples)) {
        # For each sample, look which dose is maximizing the
        # simultaneous probability to be in the target biomarker
        # range and below overdose toxicity.
        prob_target <- numeric(ncol(biom_level_samples))
        prob_target <- sapply(
          seq(1, ncol(biom_level_samples)),
          function(x) {
            sum(
              biom_level_samples[, x] >=
                stopping@target[1] * samples@data$Emax &
                biom_level_samples[, x] <=
                  stopping@target[2] * samples@data$Emax
            ) /
              nrow(biom_level_samples)
          }
        )
      } else {
        # For each sample, look which was the minimum dose giving
        # relative target level.
        targetIndex <- apply(
          biom_level_samples,
          1L,
          function(x) {
            rnx <- range(x)
            min(which(
              (x >= stopping@target[1] * diff(rnx) + rnx[1]) &
                (x <= stopping@target[2] * diff(rnx) + rnx[1] + 1e-10)
            ))
          }
        )
        prob_target <- numeric(ncol(biom_level_samples))
        tab <- table(targetIndex)
        prob_target[as.numeric(names(tab))] <- tab
        prob_target <- prob_target / nrow(biom_level_samples)
      }
    } else {
      # Otherwise the target is absolute.
      # For each sample, look which dose is maximizing the
      # simultaneous probability to be in the target biomarker
      # range and below overdose toxicity.
      prob_target <- numeric(ncol(biom_level_samples))
      prob_target <- sapply(
        seq(1, ncol(biom_level_samples)),
        function(x) {
          sum(
            biom_level_samples[, x] >= stopping@target[1] &
              biom_level_samples[, x] <= stopping@target[2]
          ) /
            nrow(biom_level_samples)
        }
      )
    }

    prob_target <- ifelse(
      is.na(dose),
      0,
      prob_target[which(data@doseGrid == dose)]
    )

    do_stop <- prob_target >= stopping@prob

    msg <- paste(
      "Probability for target biomarker is",
      round(prob_target * 100),
      "% for dose",
      dose,
      "and thus",
      ifelse(do_stop, "above", "below"),
      "the required",
      round(stopping@prob * 100),
      "%"
    )

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

## StoppingSpecificDose ----

#' @describeIn stopTrial if Stopping rule is met for specific dose of the planned
#' dose grid and not just for the default next best dose.
#'
#' @aliases stopTrial-StoppingSpecificDose
#'
#' @export
#' @example examples/Rules-method-stopTrial-StoppingSpecificDose.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingSpecificDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Specific dose must be a part of the dose grid.
    assert_subset(x = stopping@dose@.Data, choices = data@doseGrid)

    # Evaluate the original (wrapped) stopping rule at the specific dose.
    result <- stopTrial(
      stopping = stopping@rule,
      dose = stopping@dose@.Data,
      samples = samples,
      model = model,
      data = data,
      ...
    )
    # Correct the text message from the original stopping rule.
    attr(result, "message") <- gsub(
      pattern = "next best",
      replacement = "specific",
      x = attr(result, "message"),
      ignore.case = TRUE
    )

    attr(result, "report_label") <- stopping@report_label

    result
  }
)

# nolint start

## --------------------------------------------------
## Stopping when the highest dose is reached
## --------------------------------------------------

##' @describeIn stopTrial Stop when the highest dose is reached
##'
##' @example examples/Rules-method-stopTrial-StoppingHighestDose.R
setMethod(
  "stopTrial",
  signature = signature(
    stopping = "StoppingHighestDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  def = function(stopping, dose, samples, model, data, ...) {
    isHighestDose <- ifelse(
      is.na(dose),
      FALSE,
      (dose == data@doseGrid[data@nGrid])
    )
    return(structure(
      isHighestDose,
      message = paste(
        "Next best dose is",
        dose,
        "and thus",
        ifelse(isHighestDose, "the", "not the"),
        "highest dose"
      ),
      report_label = stopping@report_label
    ))
  }
)

## StoppingOrdinal ----

#' @describeIn stopTrial Stop based on value returned by next best dose.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @aliases stopTrial-StoppingOrdinal
#' @example examples/Rules-method-stopTrial-StoppingOrdinal.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingOrdinal",
    dose = "numeric",
    samples = "ANY",
    model = "LogisticLogNormalOrdinal",
    data = "DataOrdinal"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    stopTrial(
      stopping = stopping@rule,
      dose = dose,
      samples = h_convert_ordinal_samples(samples, stopping@grade),
      model = h_convert_ordinal_model(model, stopping@grade),
      data = h_convert_ordinal_data(data, stopping@grade),
      ...
    )
  }
)

#' @describeIn stopTrial Stop based on value returned by next best dose.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @aliases stopTrial-StoppingOrdinal
#' @example examples/Rules-method-stopTrial-StoppingOrdinal.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingOrdinal",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    stop(
      paste0(
        "StoppingOrdinal objects can only be used with LogisticLogNormalOrdinal ",
        "models and DataOrdinal data objects. In this case, the model is a '",
        class(model),
        "' object and the data is in a ",
        class(data),
        " object."
      )
    )
  }
)

## StoppingExternal ----

#' @describeIn stopTrial Stop based on an external flag.
#'
#' @description `r lifecycle::badge("experimental")`
#' @param external (`flag`)\cr whether to stop based on the external
#'   result or not.
#'
#' @aliases stopTrial-StoppingExternal
#' @example examples/Rules-method-stopTrial-StoppingExternal.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingExternal",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, external, ...) {
    assert_flag(external)

    msg <- paste(
      "Based on external result",
      ifelse(external, "stop", "continue")
    )

    structure(
      external,
      message = msg,
      report_label = stopping@report_label
    )
  }
)


## ============================================================

## --------------------------------------------------
## "MAX" combination of cohort size rules
## --------------------------------------------------

##' "MAX" combination of cohort size rules
##'
##' This function combines cohort size rules by taking
##' the maximum of all sizes.
##'
##' @param \dots Objects of class \code{\linkS4class{CohortSize}}
##' @return the combination as an object of class
##' \code{\linkS4class{CohortSizeMax}}
##'
##' @seealso \code{\link{minSize}}
##' @export
##' @keywords methods
setGeneric(
  "maxSize",
  def = function(...) {
    ## there should be no default method,
    ## therefore just forward to next method!
    standardGeneric("maxSize")
  },
  valueClass = "CohortSizeMax"
)

##' @describeIn maxSize The method combining cohort size rules by taking maximum
##' @example examples/Rules-method-maxSize.R
setMethod("maxSize", "CohortSize", def = function(...) {
  CohortSizeMax(list(...))
})

## --------------------------------------------------
## "MIN" combination of cohort size rules
## --------------------------------------------------

##' "MIN" combination of cohort size rules
##'
##' This function combines cohort size rules by taking
##' the minimum of all sizes.
##'
##' @param \dots Objects of class \code{\linkS4class{CohortSize}}
##' @return the combination as an object of class
##' \code{\linkS4class{CohortSizeMin}}
##'
##' @seealso \code{\link{maxSize}}
##' @export
##' @keywords methods
setGeneric(
  "minSize",
  def = function(...) {
    ## there should be no default method,
    ## therefore just forward to next method!
    standardGeneric("minSize")
  },
  valueClass = "CohortSizeMin"
)

##' @describeIn minSize The method combining cohort size rules by taking minimum
##' @example examples/Rules-method-minSize.R
setMethod("minSize", "CohortSize", def = function(...) {
  CohortSizeMin(list(...))
})

# size ----

## CohortSizeRange ----

#' @describeIn size Determines the size of the next cohort based on the range
#'   into which the next dose falls into.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeRange
#' @example examples/Rules-method-size-CohortSizeRange.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeRange"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_class(data, "Data")

    # Determine in which interval the next dose is.
    interval <- findInterval(x = dose, vec = object@intervals)
    object@cohort_size[interval]
  }
)

## CohortSizeDLT ----

#' @describeIn size Determines the size of the next cohort based on the number
#'   of DLTs so far.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeDLT
#' @example examples/Rules-method-size-CohortSizeDLT.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeDLT"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_class(data, "Data")

    # Determine how many DLTs have occurred so far.
    dlt_happened <- sum(data@y)

    # Determine in which interval this is.
    interval <- findInterval(x = dlt_happened, vec = object@intervals)
    object@cohort_size[interval]
  }
)

## CohortSizeMax ----

#' @describeIn size Determines the size of the next cohort based on maximum of
#'   multiple cohort size rules.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeMax
#' @example examples/Rules-method-size-CohortSizeMax.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeMax"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_class(data, "Data")

    # Evaluate the individual cohort size rules in the list.
    individual_results <- sapply(
      object@cohort_sizes,
      size,
      dose = dose,
      data = data
    )
    # The overall result.
    max(individual_results)
  }
)

## CohortSizeMin ----

#' @describeIn size Determines the size of the next cohort based on minimum of
#'   multiple cohort size rules.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeMin
#' @example examples/Rules-method-size-CohortSizeMin.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeMin"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_class(data, "Data")

    # Evaluate the individual cohort size rules in the list.
    individual_results <- sapply(
      object@cohort_sizes,
      size,
      dose = dose,
      data = data
    )
    # The overall result.
    min(individual_results)
  }
)

## CohortSizeConst ----

#' @describeIn size Constant cohort size.
#'
#' @param dose the next dose.
#' @param ... not used.
#'
#' @aliases size-CohortSizeConst
#' @example examples/Rules-method-size-CohortSizeConst.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeConst"
  ),
  definition = function(object, dose, ...) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      0L
    } else {
      object@size
    }
  }
)

## CohortSizeParts ----

#' @describeIn size Determines the size of the next cohort based on the parts.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeParts
#' @example examples/Rules-method-size-CohortSizeParts.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeParts"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    } else {
      assert_class(data, "DataParts")
      object@cohort_sizes[data@nextPart]
    }
  }
)

## CohortSizeOrdinal ----

#' @describeIn size Determines the size of the next cohort in a ordinal CRM trial.
#'
#' @param  dose (`numeric`) the next dose.
#' @param data the data input, an object of class [`DataOrdinal`].
#'
#' @aliases size-CohortSizeOrdinal
#' @example examples/Rules-method-size-CohortSizeOrdinal.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeOrdinal"
  ),
  definition = function(object, dose, data, ...) {
    # Validate
    assert_numeric(dose, len = 1, lower = 0)
    assert_class(data, "DataOrdinal")
    # Execute

    size(
      object@rule,
      dose = dose,
      data = h_convert_ordinal_data(data, object@grade),
      ...
    )
  }
)

## ------------------------------------------------------------------------------------------------
## Stopping based on a target ratio of the upper to the lower 95% credibility interval
## ------------------------------------------------------------------------------------------------
##' @describeIn stopTrial Stop based on 'StoppingTDCIRatio' class when
##' reaching the target ratio of the upper to the lower 95% credibility
##' interval of the estimate (TDtargetEndOfTrial). This is a stopping rule which incorporate only
##' DLE responses and DLE samples are given
##'
##' @example examples/Rules-method-stopTrialCITDsamples.R
##'
##' @export
##' @keywords methods
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingTDCIRatio",
    dose = "ANY",
    samples = "Samples",
    model = "ModelTox",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    assert_probability(stopping@prob_target)

    dose_target_samples <- dose(
      x = stopping@prob_target,
      model = model,
      samples = samples,
      ...
    )
    # 95% credibility interval.
    dose_target_ci <- quantile(dose_target_samples, probs = c(0.025, 0.975))
    dose_target_ci_ratio <- dose_target_ci[[2]] / dose_target_ci[[1]]

    do_stop <- dose_target_ci_ratio <= stopping@target_ratio
    text <- paste0(
      "95% CI is (",
      paste(dose_target_ci, collapse = ", "),
      "), Ratio = ",
      round(dose_target_ci_ratio, 4),
      " is ",
      ifelse(do_stop, "less than or equal to ", "greater than "),
      "target_ratio = ",
      stopping@target_ratio
    )
    structure(do_stop, message = text, report_label = stopping@report_label)
  }
)

## ----------------------------------------------------------------------------------------------
## Stopping based on a target ratio of the upper to the lower 95% credibility interval
## ------------------------------------------------------------------------------------------------
##' @describeIn stopTrial Stop based on 'StoppingTDCIRatio' class
##' when reaching the target ratio of the upper to the lower 95% credibility
##' interval of the estimate (TDtargetEndOfTrial). This is a stopping rule which incorporate only
##' DLE responses and no DLE samples are involved
##' @example examples/Rules-method-stopTrialCITD.R
setMethod(
  "stopTrial",
  signature = signature(
    stopping = "StoppingTDCIRatio",
    dose = "ANY",
    samples = "missing",
    model = "ModelTox",
    data = "ANY"
  ),
  def = function(stopping, dose, model, data, ...) {
    assert_probability(stopping@prob_target)

    prob_target <- stopping@prob_target
    dose_target_samples <- dose(x = prob_target, model = model, ...)
    ## Find the variance of the log of the dose_target_samples(eta)
    M1 <- matrix(
      c(
        -1 / (model@phi2),
        -(log(prob_target / (1 - prob_target)) - model@phi1) / (model@phi2)^2
      ),
      1,
      2
    )
    M2 <- model@Pcov
    varEta <- as.vector(M1 %*% M2 %*% t(M1))

    ## Find the upper and lower limit of the 95% credibility interval
    CI <- exp(log(dose_target_samples) + c(-1, 1) * 1.96 * sqrt(varEta))
    ratio <- CI[2] / CI[1]

    ## so can we stop?
    doStop <- ratio <= stopping@target_ratio
    ## generate message
    text <- paste(
      "95% CI is (",
      round(CI[1], 4),
      ",",
      round(CI[2], 4),
      "), Ratio =",
      round(ratio, 4),
      "is ",
      ifelse(doStop, "is less than or equal to", "greater than"),
      "target_ratio =",
      stopping@target_ratio
    )
    ## return both
    return(structure(
      doStop,
      message = text,
      report_label = stopping@report_label
    ))
  }
)

## --------------------------------------------------------------------------------------------------
## Stopping based on a target ratio of the upper to the lower 95% credibility interval
## ------------------------------------------------------------------------------------------------
##' @describeIn stopTrial Stop based on reaching the target ratio of the upper to the lower 95% credibility
##' interval of the estimate (the minimum of Gstar and TDtargetEndOfTrial). This is a stopping rule which
##' incorporate DLE and efficacy responses and DLE and efficacy samples are also used.
##'
##' @param 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.
##' @param Effmodel the efficacy model of \code{\linkS4class{ModelEff}} class object
##' @param Effsamples the efficacy samples of \code{\linkS4class{Samples}} class object
##' @param 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-method-stopTrialCIMaxGainSamples.R
setMethod(
  "stopTrial",
  signature = signature(
    stopping = "StoppingMaxGainCIRatio",
    dose = "ANY",
    samples = "Samples",
    model = "ModelTox",
    data = "DataDual"
  ),
  def = function(
    stopping,
    dose,
    samples,
    model,
    data,
    TDderive,
    Effmodel,
    Effsamples,
    Gstarderive,
    ...
  ) {
    prob_target <- stopping@prob_target

    ## checks
    assert_probability(prob_target)
    stopifnot(is(Effmodel, "ModelEff"))
    stopifnot(is(Effsamples, "Samples"))
    stopifnot(is.function(TDderive))
    stopifnot(is.function(Gstarderive))

    ## find the TDtarget End of Trial samples
    TDtargetEndOfTrialSamples <- dose(
      x = prob_target,
      model = model,
      samples = samples,
      ...
    )
    ## Find the TDtarget End of trial estimate
    TDtargetEndOfTrialEstimate <- TDderive(TDtargetEndOfTrialSamples)

    ## Find the gain value samples then the GstarSamples
    points <- data@doseGrid

    GainSamples <- matrix(
      nrow = size(samples),
      ncol = length(points)
    )

    ## evaluate the probs, for all gain samples.
    for (i in seq_along(points)) {
      ## Now we want to evaluate for the
      ## following dose:
      GainSamples[, i] <- gain(
        dose = points[i],
        model,
        samples,
        Effmodel,
        Effsamples,
        ...
      )
    }

    ## Find the maximum gain value samples
    MaxGainSamples <- apply(GainSamples, 1, max)

    ## Obtain Gstar samples, samples for the dose level which gives the maximum gain value
    IndexG <- apply(GainSamples, 1, which.max)
    GstarSamples <- data@doseGrid[IndexG]

    ## Find the Gstar estimate

    Gstar <- Gstarderive(GstarSamples)
    ## Find the 95% credibility interval of Gstar and its ratio of the upper to the lower limit
    CIGstar <- quantile(GstarSamples, probs = c(0.025, 0.975))
    ratioGstar <- as.numeric(CIGstar[2] / CIGstar[1])

    ## Find the 95% credibility interval of TDtargetEndOfTrial and its ratio of the upper to the lower limit
    CITDEOT <- quantile(TDtargetEndOfTrialSamples, probs = c(0.025, 0.975))
    ratioTDEOT <- as.numeric(CITDEOT[2] / CITDEOT[1])

    ## Find which is smaller (TDtargetEndOfTrialEstimate or Gstar)

    if (TDtargetEndOfTrialEstimate <= Gstar) {
      ## Find the upper and lower limit of the 95% credibility interval and its ratio of the smaller
      CI <- CITDEOT
      ratio <- ratioTDEOT
      chooseTD <- TRUE
    } else {
      CI <- CIGstar
      ratio <- ratioGstar
      chooseTD <- FALSE
    }

    ## so can we stop?
    doStop <- ratio <= stopping@target_ratio
    ## generate message
    text1 <- paste(
      "Gstar estimate is",
      round(Gstar, 4),
      "with 95% CI (",
      round(CIGstar[1], 4),
      ",",
      round(CIGstar[2], 4),
      ") and its ratio =",
      round(ratioGstar, 4)
    )
    text2 <- paste(
      "TDtargetEndOfTrial estimate is ",
      round(TDtargetEndOfTrialEstimate, 4),
      "with 95% CI (",
      round(CITDEOT[1], 4),
      ",",
      round(CITDEOT[2], 4),
      ") and its ratio=",
      round(ratioTDEOT, 4)
    )
    text3 <- paste(
      ifelse(chooseTD, "TDtargetEndOfTrial estimate", "Gstar estimate"),
      "is smaller with ratio =",
      round(ratio, 4),
      " which is ",
      ifelse(doStop, "is less than or equal to", "greater than"),
      "target_ratio =",
      stopping@target_ratio
    )
    text <- c(text1, text2, text3)
    ## return both
    return(structure(
      doStop,
      message = text,
      report_label = stopping@report_label
    ))
  }
)

## -----------------------------------------------------------------------------------------------
## Stopping based on a target ratio of the upper to the lower 95% credibility interval
## --------------------------------------------------------------------------------------------
##' @describeIn stopTrial Stop based on reaching the target ratio of the upper to the lower 95% credibility
##' interval of the estimate (the minimum of Gstar and TDtargetEndOfTrial). This is a stopping rule which
##' incorporate DLE and efficacy responses without DLE and efficacy samples involved.
##' @example examples/Rules-method-stopTrialCIMaxGain.R
setMethod(
  "stopTrial",
  signature = signature(
    stopping = "StoppingMaxGainCIRatio",
    dose = "ANY",
    samples = "missing",
    model = "ModelTox",
    data = "DataDual"
  ),
  def = function(stopping, dose, model, data, Effmodel, ...) {
    prob_target <- stopping@prob_target

    ## checks
    assert_probability(prob_target)
    stopifnot(is(Effmodel, "ModelEff"))

    ## find the TDtarget End of Trial
    TDtargetEndOfTrial <- dose(
      x = prob_target,
      model = model,
      ...
    )

    ## Find the dose with maximum gain value
    Gainfun <- function(DOSE) {
      -gain(DOSE, model_dle = model, model_eff = Effmodel, ...)
    }

    # if(data@placebo) {
    # n <- length(data@doseGrid)
    # LowestDose <- sort(data@doseGrid)[2]} else {
    LowestDose <- min(data@doseGrid)
    # }

    Gstar <- (optim(
      LowestDose,
      Gainfun,
      method = "L-BFGS-B",
      lower = LowestDose,
      upper = max(data@doseGrid)
    )$par)
    MaxGain <- -(optim(
      LowestDose,
      Gainfun,
      method = "L-BFGS-B",
      lower = LowestDose,
      upper = max(data@doseGrid)
    )$value)
    if (data@placebo) {
      logGstar <- log(Gstar + Effmodel@const)
    } else {
      logGstar <- log(Gstar)
    }

    ## From paper (Yeung et. al 2015)

    meanEffGstar <- Effmodel@theta1 + Effmodel@theta2 * log(logGstar)

    denom <- (model@phi2) * (meanEffGstar) * (1 + logGstar * model@phi2)

    dgphi1 <- -(meanEffGstar * logGstar * model@phi2 - Effmodel@theta2) / denom

    dgphi2 <- -((meanEffGstar) *
      logGstar +
      meanEffGstar * (logGstar)^2 * model@phi2 -
      Effmodel@theta2 * logGstar) /
      denom

    dgtheta1 <- -(logGstar * model@phi2) / denom

    dgtheta2 <- -(logGstar *
      exp(model@phi1 + model@phi2 * logGstar) *
      model@phi2 *
      log(logGstar) -
      1 -
      exp(model@phi1 + model@phi2 * logGstar)) /
      denom

    # DLEPRO <- exp(model@phi1+model@phi2*logGstar)

    # dgphi1 <- Effmodel@theta2*DLEPRO - logGstar*model@phi2*meanEffGstar*DLEPRO

    # dgphi2 <- logGstar*DLEPRO *(Effmodel@theta2-(meanEffGstar)+model@phi2)

    # dgtheta1 <- -logGstar*DLEPRO*model@phi2

    # dgtheta2 <- 1+DLEPRO-logGstar*DLEPRO*model@phi2*log(logGstar)

    deltaG <- matrix(c(dgphi1, dgphi2, dgtheta1, dgtheta2), 4, 1)

    ## Find the variance of the log Gstar
    ## First find the covariance matrix of all the parameters, phi1, phi2, theta1 and theta2
    ## such that phi1 and phi2 and independent of theta1 and theta2
    emptyMatrix <- matrix(0, 2, 2)
    covBETA <- cbind(
      rbind(model@Pcov, emptyMatrix),
      rbind(emptyMatrix, Effmodel@Pcov)
    )
    varlogGstar <- as.vector(t(deltaG) %*% covBETA %*% deltaG)

    ## Find the upper and lower limit of the 95% credibility interval of Gstar
    CIGstar <- exp(logGstar + c(-1, 1) * 1.96 * sqrt(varlogGstar))

    ## The ratio of the upper to the lower 95% credibility interval
    ratioGstar <- CIGstar[2] / CIGstar[1]

    ## Find the variance of the log of the TDtargetEndOfTrial(eta)
    M1 <- matrix(
      c(
        -1 / (model@phi2),
        -(log(prob_target / (1 - prob_target)) - model@phi1) / (model@phi2)^2
      ),
      1,
      2
    )
    M2 <- model@Pcov

    varEta <- as.vector(M1 %*% M2 %*% t(M1))

    ## Find the upper and lower limit of the 95% credibility interval of
    ## TDtargetEndOfTrial
    CITDEOT <- exp(log(TDtargetEndOfTrial) + c(-1, 1) * 1.96 * sqrt(varEta))

    ## The ratio of the upper to the lower 95% credibility interval
    ratioTDEOT <- CITDEOT[2] / CITDEOT[1]

    if (Gstar <= TDtargetEndOfTrial) {
      chooseTD <- FALSE
      CI <- c()
      CI[2] <- CIGstar[2]
      CI[1] <- CIGstar[1]
      ratio <- ratioGstar
    } else {
      chooseTD <- TRUE
      CI <- c()
      CI[2] <- CITDEOT[2]
      CI[1] <- CITDEOT[1]
      ratio <- ratioTDEOT
    }
    ## so can we stop?
    doStop <- ratio <= stopping@target_ratio
    ## generate message

    text1 <- paste(
      "Gstar estimate is",
      round(Gstar, 4),
      "with 95% CI (",
      round(CIGstar[1], 4),
      ",",
      round(CIGstar[2], 4),
      ") and its ratio =",
      round(ratioGstar, 4)
    )
    text2 <- paste(
      "TDtargetEndOfTrial estimate is ",
      round(TDtargetEndOfTrial, 4),
      "with 95% CI (",
      round(CITDEOT[1], 4),
      ",",
      round(CITDEOT[2], 4),
      ") and its ratio=",
      round(ratioTDEOT, 4)
    )
    text3 <- paste(
      ifelse(chooseTD, "TDatrgetEndOfTrial estimate", "Gstar estimate"),
      "is smaller with ratio =",
      round(ratio, 4),
      "which is ",
      ifelse(doStop, "is less than or equal to", "greater than"),
      "target_ratio =",
      stopping@target_ratio
    )
    text <- c(text1, text2, text3)
    ## return both
    return(structure(
      doStop,
      message = text,
      report_label = stopping@report_label
    ))
  }
)


## ============================================================

## -----------------------------------------------------
## Determine the safety window length of the next cohort
## -----------------------------------------------------

##' Determine the safety window length of the next cohort
##'
##' This function determines the safety window length of
##' the next cohort.
##'
##' @param safetyWindow The rule, an object of class
##' \code{\linkS4class{SafetyWindow}}
##' @param size The next cohort size
##' @param data The data input, an object of class \code{\linkS4class{DataDA}}
##' @param \dots additional arguments
##'
##' @return the `windowLength` as a list of safety window parameters
##' (`gap`, `follow`, `follow_min`)
##'
##' @export
##' @keywords methods
setGeneric(
  "windowLength",
  def = function(safetyWindow, size, ...) {
    ## there should be no default method,
    ## therefore just forward to next method!
    standardGeneric("windowLength")
  },
  valueClass = "list"
)


## ============================================================

## --------------------------------------------------
## The SafetyWindowSize method
## --------------------------------------------------

##' @describeIn windowLength Determine safety window length based
##' on the cohort size
##'
##' @example examples/Rules-method-windowLength-SafetyWindowSize.R
setMethod(
  "windowLength",
  signature = signature(
    safetyWindow = "SafetyWindowSize",
    size = "ANY"
  ),
  def = function(safetyWindow, size, data, ...) {
    ## determine in which interval the next size is
    interval <-
      findInterval(
        x = size,
        vec = safetyWindow@size
      )

    ## so the safety window length is
    patientGap <- head(
      c(
        0,
        safetyWindow@gap[[interval]],
        rep(tail(safetyWindow@gap[[interval]], 1), 100)
      ),
      size
    )
    patientFollow <- safetyWindow@follow
    patientFollowMin <- safetyWindow@follow_min

    ret <- list(
      patientGap = patientGap,
      patientFollow = patientFollow,
      patientFollowMin = patientFollowMin
    )

    return(ret)
  }
)

## ============================================================

## --------------------------------------------------
## Constant safety window length
## --------------------------------------------------

##' @describeIn windowLength Constant safety window length
##' @example examples/Rules-method-windowLength-SafetyWindowConst.R
setMethod(
  "windowLength",
  signature = signature(
    safetyWindow = "SafetyWindowConst",
    size = "ANY"
  ),
  def = function(safetyWindow, size, ...) {
    ## first element should be 0.
    patientGap <- head(
      c(
        0,
        safetyWindow@gap,
        rep(tail(safetyWindow@gap, 1), 100)
      ),
      size
    )
    patientFollow <- safetyWindow@follow
    patientFollowMin <- safetyWindow@follow_min

    ret <- list(
      patientGap = patientGap,
      patientFollow = patientFollow,
      patientFollowMin = patientFollowMin
    )

    return(ret)
  }
)

# nolint end

# tidy ----

## tidy-IncrementsRelative ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelative
#' @example examples/Rules-method-tidyIncrementsRelative.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelative"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(max > 0) %>%
      tibble::add_column(increment = x@increments) %>%
      h_tidy_class(x)
  }
)

## tidy-CohortSizeDLT ----

#' @rdname tidy
#' @aliases tidy-CohortSizeDLT
#' @example examples/Rules-method-tidyCohortSizeDLT.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeDLT"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(max > 0) %>%
      tibble::add_column(cohort_size = x@cohort_size) %>%
      h_tidy_class(x)
  }
)

## tidy-CohortSizeMin ----

#' @rdname tidy
#' @aliases tidy-CohortSizeMin
#' @example examples/Rules-method-tidyCohortSizeMin.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeMin"),
  definition = function(x, ...) {
    callNextMethod() %>% h_tidy_class(x)
  }
)

## tidy-CohortSizeMax ----

#' @rdname tidy
#' @aliases tidy-CohortSizeMax
#' @example examples/Rules-method-tidyCohortSizeMax.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeMax"),
  definition = function(x, ...) {
    callNextMethod() %>% h_tidy_class(x)
  }
)

## tidy-CohortSizeRange ----

#' @rdname tidy
#' @aliases tidy-CohortSizeRange
#' @example examples/Rules-method-tidyCohortSizeRange.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeRange"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(max > 0) %>%
      tibble::add_column(cohort_size = x@cohort_size) %>%
      h_tidy_class(x)
  }
)

## tidy-CohortSizeParts ----

#' @rdname tidy
#' @aliases tidy-CohortSizeParts
#' @example examples/Rules-method-tidyCohortSizeParts.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeParts"),
  definition = function(x, ...) {
    tibble::tibble(
      part = seq_along(x@cohort_sizes),
      cohort_size = x@cohort_sizes
    ) %>%
      h_tidy_class(x)
  }
)

## tidy-IncrementsMin ----

#' @rdname tidy
#' @aliases tidy-IncrementsMin
#' @example examples/Rules-method-tidyIncrementsMin.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsMin"),
  definition = function(x, ...) {
    callNextMethod() %>% h_tidy_class(x)
  }
)

## tidy-IncrementsRelative ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelative
#' @example examples/Rules-method-tidyIncrementsRelative.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelative"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(dplyr::row_number() > 1) %>%
      tibble::add_column(increment = x@increments) %>%
      h_tidy_class(x)
  }
)

## tidy-IncrementsRelativeDLT ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelativeDLT
#' @example examples/Rules-method-tidyIncrementsRelativeDLT.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelativeDLT"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(dplyr::row_number() > 1) %>%
      tibble::add_column(increment = x@increments) %>%
      h_tidy_class(x)
  }
)

## tidy-IncrementsRelative ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelativeParts
#' @example examples/Rules-method-tidyIncrementsRelativeParts.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelativeParts"),
  definition = function(x, ...) {
    slot_names <- slotNames(x)
    rv <- list()
    for (nm in slot_names) {
      if (!is.function(slot(x, nm))) {
        rv[[nm]] <- h_tidy_slot(x, nm, ...)
      }
    }
    # Column bind of all list elements have the same number of rows.
    if (length(rv) > 1 & length(unique(sapply(rv, nrow))) == 1) {
      rv <- rv %>% dplyr::bind_cols()
    }
    rv <- rv %>% h_tidy_class(x)
    if (length(rv) == 1) {
      rv[[names(rv)[1]]] %>% h_tidy_class(x)
    } else {
      rv
    }
  }
)

## tidy-NextBestNCRM ----

#' @rdname tidy
#' @aliases tidy-NextBestNCRM
#' @example examples/Rules-method-tidyNextBestNCRM.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "NextBestNCRM"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$target, range_min = 0, range_max = 1) %>%
      add_column(max_prob = c(NA, NA, x@max_overdose_prob)) %>%
      add_column(Range = c("Underdose", "Target", "Overdose"), .before = 1) %>%
      h_tidy_class(x)
  }
)

## tidy-NextBestNCRMLoss ----

#' @rdname tidy
#' @aliases tidy-NextBestNCRMLoss
#' @example examples/Rules-method-tidyNextBestNCRMLoss.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "NextBestNCRMLoss"),
  definition = function(x, ...) {
    tibble(
      Range = "Underdose",
      Lower = 0,
      Upper = x@target[1]
    ) %>%
      dplyr::bind_rows(
        lapply(
          c("target", "overdose", "unacceptable"),
          function(nm, obj) {
            tibble::tibble(
              Range = stringr::str_to_sentence(nm),
              Lower = slot(obj, nm)[1],
              Upper = slot(obj, nm)[2]
            )
          },
          obj = x
        ) %>%
          dplyr::bind_rows()
      ) %>%
      add_column(LossCoefficient = x@losses) %>%
      add_column(MaxOverdoseProb = x@max_overdose_prob) %>%
      h_tidy_class(x)
  }
)

# nolint start
#####################################################################################
## 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: <[Simulations-methods.R] by DSB Fre 16/01/2015 13:41>
##
## Description:
## Methods for handling the simulations output.
##
## History:
## 19/02/2014   file creation
## 30/07/2014   added in methods for pseudo models simulations
###################################################################################

##' @include Simulations-class.R
##' @include helpers.R
{}


##' Plot simulations
##'
##' Summarize the simulations with plots
##'
##' This plot method can be applied to \code{\linkS4class{GeneralSimulations}}
##' objects in order to summarize them graphically. Possible \code{type}s of
##' plots at the moment are: \describe{ \item{trajectory}{Summary of the
##' trajectory of the simulated trials} \item{dosesTried}{Average proportions of
##' the doses tested in patients} } You can specify one or both of these in the
##' \code{type} argument.
##'
##' @param x the \code{\linkS4class{GeneralSimulations}} object we want
##' to plot from
##' @param y missing
##' @param type the type of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a `gtable` object.
##'
##' @importFrom ggplot2 ggplot geom_step geom_bar aes xlab ylab
##' scale_linetype_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSIMsingle.R
##' @export
##' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "GeneralSimulations",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "trajectory",
      "dosesTried"
    ),
    ...
  ) {
    ## which plots should be produced?
    type <- match.arg(type, several.ok = TRUE)
    stopifnot(length(type) > 0L)

    ## start the plot list
    plotList <- list()
    plotIndex <- 0L

    ## summary of the trajectories
    if ("trajectory" %in% type) {
      ## get a matrix of the simulated dose trajectories,
      ## where the rows correspond to the simulations and
      ## the columns to the patient index:

      ## If design with placebo, then exclude placebo Patients
      if (x@data[[1]]@placebo) {
        PL <- x@data[[1]]@doseGrid[1]
        simDoses <- lapply(
          x@data,
          function(y) {
            y@x[y@x != PL]
          }
        )
      } else {
        simDoses <- lapply(
          x@data,
          slot,
          "x"
        )
      }

      maxPatients <- max(sapply(simDoses, length))

      simDosesMat <- matrix(
        data = NA,
        nrow = length(simDoses),
        ncol = maxPatients
      )

      for (i in seq_along(simDoses)) {
        simDosesMat[i, seq_along(simDoses[[i]])] <-
          simDoses[[i]]
      }

      ## extract statistics
      stats <- c(
        "Minimum",
        "Lower Quartile",
        "Median",
        "Upper Quartile",
        "Maximum"
      )
      traj.df <-
        data.frame(
          patient = rep(seq_len(maxPatients), each = 5L),
          Statistic = factor(
            rep(
              stats,
              maxPatients
            ),
            levels = stats
          ),
          traj = c(apply(simDosesMat, 2L, quantile, na.rm = TRUE))
        )

      ## linetypes for the plot
      lt <- c(
        "Median" = 1,
        "Lower Quartile" = 2,
        "Upper Quartile" = 2,
        "Minimum" = 4,
        "Maximum" = 4
      )

      ## save the plot
      if (x@data[[1]]@placebo) {
        myTitle <- "Patient (placebo were excluded)"
      } else {
        myTitle <- "Patient"
      }
      plotList[[plotIndex <- plotIndex + 1L]] <-
        ggplot() +
        geom_step(
          aes(
            x = patient,
            y = traj,
            group = Statistic,
            linetype = Statistic
          ),
          size = 1.2,
          colour = "blue",
          data = traj.df
        ) +
        ## scale_linetype_manual(values=lt) +
        xlab(myTitle) +
        ylab("Dose Level")
    }

    ## average distribution of the doses tried
    if ("dosesTried" %in% type) {
      ## get the doses tried
      simDoses <- lapply(
        x@data,
        slot,
        "x"
      )

      ## get the dose distributions by trial
      doseDistributions <-
        sapply(
          simDoses,
          function(s) {
            if (length(s) > 0) {
              prop.table(table(factor(s, levels = x@data[[1]]@doseGrid)))
            } else {
              rep(0, length(x@data[[1]]@doseGrid))
            }
          }
        )

      ## derive the average dose distribution across trial
      ## simulations
      averageDoseDist <- rowMeans(doseDistributions)

      ## get in data frame shape
      dat <- data.frame(
        dose = as.numeric(names(averageDoseDist)),
        perc = averageDoseDist * 100
      )

      ## produce and save the plot
      plotList[[plotIndex <- plotIndex + 1L]] <-
        ggplot() +
        geom_bar(
          data = as.data.frame(dat),
          aes(x = dose, y = perc),
          stat = "identity",
          position = "identity",
          width = min(diff(x@data[[1]]@doseGrid)) / 2
        ) +
        xlab("Dose level") +
        ylab("Average proportion [%]")
    }
    ## then finally plot everything

    ## if there is only one plot
    if (
      identical(
        length(plotList),
        1L
      )
    ) {
      ## just return it
      return(plotList[[1L]])
    } else {
      ## otherwise arrange them
      ret <- do.call(
        gridExtra::arrangeGrob,
        plotList
      )
      return(ret)
    }
  }
)


##' Plot dual-endpoint simulations
##'
##' This plot method can be applied to \code{\linkS4class{DualSimulations}}
##' objects in order to summarize them graphically. In addition to the standard
##' plot types, there is
##' \describe{
##' \item{sigma2W}{Plot a boxplot of the final biomarker variance estimates in
##' the simulated trials}
##' \item{rho}{Plot a boxplot of the final correlation estimates in
##' the simulated trials}
##' }
##'
##' @param x the \code{\linkS4class{DualSimulations}} object we want
##' to plot from
##' @param y missing
##' @param type the type of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a `gtable` object.
##'
##' @importFrom ggplot2 qplot coord_flip scale_x_discrete
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plot-DualSimulations.R
##' @export
##' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "DualSimulations",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "trajectory",
      "dosesTried",
      "sigma2W",
      "rho"
    ),
    ...
  ) {
    ## start the plot list
    plotList <- list()
    plotIndex <- 0L

    ## which plots should be produced?
    type <- match.arg(type, several.ok = TRUE)
    stopifnot(length(type) > 0L)

    ## substract the specific plot types for
    ## dual-endpoint simulation results
    typeReduced <- setdiff(
      type,
      c("sigma2W", "rho")
    )

    ## are there more plots from general?
    moreFromGeneral <- (length(typeReduced) > 0)

    ## if so, then produce these plots
    if (moreFromGeneral) {
      genPlot <- callNextMethod(x = x, y = y, type = typeReduced)
    }

    ## now to the specific dual-endpoint plots:

    ## biomarker variance estimates boxplot
    if ("sigma2W" %in% type) {
      ## save the plot
      plotList[[plotIndex <- plotIndex + 1L]] <-
        qplot(
          factor(0),
          y = y,
          data = data.frame(y = x@sigma2w_est),
          geom = "boxplot",
          xlab = "",
          ylab = "Biomarker variance estimates"
        ) +
        coord_flip() +
        scale_x_discrete(breaks = NULL)
    }

    ## correlation estimates boxplot
    if ("rho" %in% type) {
      ## save the plot
      plotList[[plotIndex <- plotIndex + 1L]] <-
        qplot(
          factor(0),
          y = y,
          data = data.frame(y = x@rho_est),
          geom = "boxplot",
          xlab = "",
          ylab = "Correlation estimates"
        ) +
        coord_flip() +
        scale_x_discrete(breaks = NULL)
    }

    ## then finally plot everything
    if (
      identical(
        length(plotList),
        0L
      )
    ) {
      return(genPlot)
    } else if (
      identical(
        length(plotList),
        1L
      )
    ) {
      ret <- plotList[[1L]]
    } else {
      ret <- do.call(
        gridExtra::arrangeGrob,
        plotList
      )
    }

    if (moreFromGeneral) {
      ret <- gridExtra::arrangeGrob(genPlot, ret)
    }

    return(ret)
  }
)


##' Summarize the simulations, relative to a given truth
##'
##' @param object the \code{\linkS4class{GeneralSimulations}} object we want to
##' summarize
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity
##' @param target the target toxicity interval (default: 20-35%) used for the
##' computations
##' @param \dots Additional arguments can be supplied here for \code{truth}
##' @return an object of class \code{\linkS4class{GeneralSimulationsSummary}}
##'
##' @export
##' @keywords methods
setMethod(
  "summary",
  signature = signature(object = "GeneralSimulations"),
  def = function(object, truth, target = c(0.2, 0.35), ...) {
    ## extract dose grid
    doseGrid <- object@data[[1]]@doseGrid

    ## evaluate true toxicity at doseGrid
    trueTox <- truth(doseGrid, ...)

    ## find dose interval corresponding to target tox interval
    targetDoseInterval <-
      sapply(
        target,
        function(t) {
          ## we have to be careful because it might be
          ## that in the range of the dose grid, no
          ## doses can be found that match the target
          ## interval boundaries!
          ## In that case we want to return NA
          r <- try(
            uniroot(
              f = function(x) {
                truth(x, ...) - t
              },
              interval = range(doseGrid)
            )$root,
            silent = TRUE
          )
          if (inherits(r, "try-error")) {
            return(NA_real_)
          } else {
            return(r)
          }
        }
      )

    ## what are the levels above target interval?
    xAboveTarget <- which(trueTox > target[2])

    ## proportion of DLTs in a trial:
    if (object@data[[1]]@placebo) {
      if (sum(object@data[[1]]@x == doseGrid[1])) {
        propDLTs <- sapply(
          object@data,
          function(d) {
            tapply(
              d@y,
              factor(d@x == d@doseGrid[1], labels = c("ACTV", "PLCB")),
              mean
            )
          }
        )
      } else {
        propDLTs <- sapply(
          object@data,
          function(d) {
            c("ACTV" = mean(d@y), "PLCB" = NA)
          }
        )
      }
    } else {
      propDLTs <- sapply(
        object@data,
        function(d) {
          mean(d@y)
        }
      )
    }

    ## mean toxicity risk
    if (object@data[[1]]@placebo) {
      meanToxRisk <- sapply(
        object@data,
        function(d) {
          mean(trueTox[d@xLevel[d@xLevel != 1]])
        }
      )
    } else {
      meanToxRisk <- sapply(
        object@data,
        function(d) {
          mean(trueTox[d@xLevel])
        }
      )
    }

    ## doses selected for MTD
    doseSelected <- object@doses

    ## replace NA by 0
    doseSelected[is.na(doseSelected)] <- 0

    ## dose most often selected as MTD
    doseMostSelected <-
      as.numeric(names(which.max(table(doseSelected))))
    xMostSelected <-
      match_within_tolerance(doseMostSelected, table = doseGrid)

    ## observed toxicity rate at dose most often selected
    ## Note: this does not seem very useful!
    ## Reason: In case of a fine grid, few patients if any
    ## will have been treated at this dose.
    tmp <-
      sapply(
        object@data,
        function(d) {
          whichAtThisDose <- which(d@x == doseMostSelected)
          nAtThisDose <- length(whichAtThisDose)
          nDLTatThisDose <- sum(d@y[whichAtThisDose])
          return(c(
            nAtThisDose = nAtThisDose,
            nDLTatThisDose = nDLTatThisDose
          ))
        }
      )

    obsToxRateAtDoseMostSelected <-
      mean(tmp["nDLTatThisDose", ]) / mean(tmp["nAtThisDose", ])

    ## number of patients overall
    if (object@data[[1]]@placebo) {
      nObs <- sapply(
        object@data,
        function(x) {
          data.frame(
            n.ACTV = sum(x@xLevel != 1L),
            n.PLCB = sum(x@xLevel == 1L)
          )
        }
      )
      nObs <- matrix(unlist(nObs), dim(nObs))
    } else {
      nObs <- sapply(
        object@data,
        slot,
        "nObs"
      )
    }

    ## number of patients treated above target tox interval
    nAboveTarget <- sapply(
      object@data,
      function(d) {
        sum(d@xLevel %in% xAboveTarget)
      }
    )

    ## Proportion of trials selecting target MTD
    toxAtDoses <- truth(doseSelected, ...)
    propAtTarget <- mean(
      (toxAtDoses > target[1]) &
        (toxAtDoses < target[2])
    )

    ## give back an object of class GeneralSimulationsSummary,
    ## for which we then define a print / plot method
    ret <-
      .GeneralSimulationsSummary(
        target = target,
        target_dose_interval = targetDoseInterval,
        nsim = length(object@data),
        prop_dlts = propDLTs,
        mean_tox_risk = meanToxRisk,
        dose_selected = doseSelected,
        dose_most_selected = doseMostSelected,
        obs_tox_rate_at_dose_most_selected = obsToxRateAtDoseMostSelected,
        n_obs = nObs,
        n_above_target = nAboveTarget,
        tox_at_doses_selected = toxAtDoses,
        prop_at_target = propAtTarget,
        dose_grid = doseGrid,
        placebo = object@data[[1]]@placebo
      )
    return(ret)
  }
)


##' Summarize the model-based design simulations, relative to a given truth
##'
##' @param object the \code{\linkS4class{Simulations}} object we want to
##' summarize
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity
##' @param target the target toxicity interval (default: 20-35%) used for the
##' computations
##' @param \dots Additional arguments can be supplied here for \code{truth}
##' @return an object of class \code{\linkS4class{SimulationsSummary}}
##'
##' @example examples/Simulations-method-summary.R
##' @export
##' @keywords methods
setMethod(
  "summary",
  signature = signature(object = "Simulations"),
  def = function(object, truth, target = c(0.2, 0.35), ...) {
    ## call the parent method
    start <- callNextMethod(
      object = object,
      truth = truth,
      target = target,
      ...
    )

    doseGrid <- object@data[[1]]@doseGrid

    ## dose level most often selected as MTD
    xMostSelected <-
      match_within_tolerance(start@dose_most_selected, table = doseGrid)

    ## fitted toxicity rate at dose most often selected
    fitAtDoseMostSelected <-
      sapply(
        object@fit,
        function(f) {
          f$middle[xMostSelected]
        }
      )

    ## mean fitted toxicity (average, lower and upper quantiles)
    ## at each dose level
    ## (this is required for plotting)
    meanFitMatrix <- sapply(
      object@fit,
      "[[",
      "middle"
    )
    meanFit <- list(
      truth = truth(doseGrid, ...),
      average = rowMeans(meanFitMatrix),
      lower = apply(
        meanFitMatrix,
        1L,
        quantile,
        0.025
      ),
      upper = apply(
        meanFitMatrix,
        1L,
        quantile,
        0.975
      )
    )

    ## give back an object of class SimulationsSummary,
    ## for which we then define a print / plot method
    ret <- .SimulationsSummary(
      start,
      stop_report = object@stop_report,
      additional_stats = object@additional_stats,
      fit_at_dose_most_selected = fitAtDoseMostSelected,
      mean_fit = meanFit
    )

    return(ret)
  }
)

##' Summarize the dual-endpoint design simulations, relative to given true
##' dose-toxicity and dose-biomarker curves
##'
##' @param object the \code{\linkS4class{DualSimulations}} object we want to
##' summarize
##' @param trueTox a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity.
##' @param trueBiomarker a function which takes as input a dose (vector) and
##' returns the true biomarker level (vector).
##' @param target the target toxicity interval (default: 20-35%) used for the
##' computations
##' @param \dots Additional arguments can be supplied here for \code{trueTox}
##' and \code{trueBiomarker}
##' @return an object of class \code{\linkS4class{DualSimulationsSummary}}
##'
##' @example examples/Simulations-method-summary-DualSimulations.R
##' @export
##' @keywords methods
setMethod(
  "summary",
  signature = signature(object = "DualSimulations"),
  def = function(object, trueTox, trueBiomarker, target = c(0.2, 0.35), ...) {
    ## call the parent method
    start <- callNextMethod(
      object = object,
      truth = trueTox,
      target = target,
      ...
    )

    doseGrid <- object@data[[1]]@doseGrid

    ## dose level most often selected as MTD
    xMostSelected <-
      match_within_tolerance(start@dose_most_selected, table = doseGrid)

    ## fitted biomarker level at dose most often selected
    biomarkerFitAtDoseMostSelected <-
      sapply(
        object@fit_biomarker,
        function(f) {
          f$middleBiomarker[xMostSelected]
        }
      )

    ## mean fitted biomarker curve (average, lower and upper quantiles)
    ## at each dose level
    ## (this is required for plotting)
    meanBiomarkerFitMatrix <- sapply(
      object@fit_biomarker,
      "[[",
      "middleBiomarker"
    )
    meanBiomarkerFit <- list(
      truth = trueBiomarker(doseGrid, ...),
      average = rowMeans(meanBiomarkerFitMatrix),
      lower = apply(
        meanBiomarkerFitMatrix,
        1L,
        quantile,
        0.025
      ),
      upper = apply(
        meanBiomarkerFitMatrix,
        1L,
        quantile,
        0.975
      )
    )

    ## give back an object of class DualSimulationsSummary,
    ## for which we then define a print / plot method
    ret <- .DualSimulationsSummary(
      start,
      biomarker_fit_at_dose_most_selected = biomarkerFitAtDoseMostSelected,
      mean_biomarker_fit = meanBiomarkerFit
    )

    return(ret)
  }
)

##' A Reference Class to represent sequentially updated reporting objects.
##' @name Report
##' @field object The object from which to report
##' @field df the data frame to which columns are sequentially added
##' @field dfNames the names to which strings are sequentially added
Report <-
  setRefClass(
    "Report",
    fields = list(
      object = "ANY",
      df = "data.frame",
      dfNames = "character"
    ),
    methods = list(
      dfSave = function(res, name) {
        df <<- cbind(df, res)
        dfNames <<- c(dfNames, name)
        return(res)
      },
      report = function(
        slotName,
        description,
        percent = TRUE,
        digits = 0,
        quantiles = c(0.1, 0.9),
        subset = NULL,
        doSum = FALSE
      ) {
        vals <- slot(object, name = slotName)
        if (!is.null(subset)) {
          vals <- vals[subset, ]
        }
        if (doSum) {
          vals <- apply(vals, 2, sum)
        }
        if (percent) {
          unit <- " %"
          vals <- vals * 100
        } else {
          unit <- ""
        }

        res <- paste(
          round(mean(vals), digits),
          unit,
          " (",
          paste(
            round(
              quantile(vals, quantiles, na.rm = TRUE),
              digits
            ),
            unit,
            collapse = ", ",
            sep = ""
          ),
          ")",
          sep = ""
        )

        ## print result to the buffer
        cat(
          description,
          ":",
          "mean",
          dfSave(res, slotName),
          "\n"
        )
      }
    )
  )


##' Show the summary of the simulations
##'
##' @param object the \code{\linkS4class{GeneralSimulationsSummary}} object we want
##' to print
##' @return invisibly returns a data frame of the results with one row and
##' appropriate column names
##'
##' @export
##' @keywords methods
setMethod(
  "show",
  signature = signature(object = "GeneralSimulationsSummary"),
  def = function(object) {
    r <- Report$new(
      object = object,
      df = as.data.frame(matrix(
        nrow = 1,
        ncol = 0
      )),
      dfNames = character()
    )

    cat(
      "Summary of",
      r$dfSave(object@nsim, "nsim"),
      "simulations\n\n"
    )

    cat(
      "Target toxicity interval was",
      r$dfSave(
        paste(round(object@target * 100), collapse = ", "),
        "target"
      ),
      "%\n"
    )
    cat(
      "Target dose interval corresponding to this was",
      r$dfSave(
        paste(round(object@target_dose_interval, 1), collapse = ", "),
        "target_dose_interval"
      ),
      "\n"
    )
    cat(
      "Intervals are corresponding to",
      "10 and 90 % quantiles\n\n"
    )

    if (object@placebo) {
      r$report(
        "n_obs",
        "Number of patients on placebo",
        percent = FALSE,
        subset = 2
      )
      r$report(
        "n_obs",
        "Number of patients on active",
        percent = FALSE,
        subset = 1
      )
      r$report(
        "n_obs",
        "Number of patients overall",
        percent = FALSE,
        doSum = TRUE
      )
    } else {
      r$report("n_obs", "Number of patients overall", percent = FALSE)
    }
    r$report(
      "n_above_target",
      "Number of patients treated above target tox interval",
      percent = FALSE
    )

    if (object@placebo) {
      r$report(
        "prop_dlts",
        "Proportions of DLTs in the trials for patients on placebo",
        subset = 2
      )
      r$report(
        "prop_dlts",
        "Proportions of DLTs in the trials for patients on active",
        subset = 1
      )
    } else {
      r$report(
        "prop_dlts",
        "Proportions of DLTs in the trials"
      )
    }
    r$report(
      "mean_tox_risk",
      "Mean toxicity risks for the patients on active"
    )
    r$report(
      "dose_selected",
      "Doses selected as MTD",
      percent = FALSE,
      digits = 1
    )
    r$report(
      "tox_at_doses_selected",
      "True toxicity at doses selected"
    )
    cat(
      "Proportion of trials selecting target MTD:",
      r$dfSave(
        object@prop_at_target * 100,
        "prop_at_target"
      ),
      "%\n"
    )
    cat(
      "Dose most often selected as MTD:",
      r$dfSave(
        object@dose_most_selected,
        "dose_most_selected"
      ),
      "\n"
    )
    cat(
      "Observed toxicity rate at dose most often selected:",
      r$dfSave(
        round(object@obs_tox_rate_at_dose_most_selected * 100),
        "obs_tox_rate_at_dose_most_selected"
      ),
      "%\n"
    )

    ## finally assign names to the df
    ## and return it invisibly
    names(r$df) <- r$dfNames
    invisible(r$df)
  }
)

##' Show the summary of the simulations
##'
##' @param object the \code{\linkS4class{SimulationsSummary}} object we want
##' to print
##' @return invisibly returns a data frame of the results with one row and
##' appropriate column names
##'
##' @example examples/Simulations-method-show-SimulationsSummary.R
##' @export
##' @keywords methods
setMethod(
  "show",
  signature = signature(object = "SimulationsSummary"),
  def = function(object) {
    ## call the parent method
    df <- callNextMethod(object)
    dfNames <- names(df)

    ## start report object
    r <- Report$new(
      object = object,
      df = df,
      dfNames = dfNames
    )

    ## add one reporting line
    r$report(
      "fit_at_dose_most_selected",
      "Fitted toxicity rate at dose most often selected"
    )

    # Report results of additional statistics summary

    if (length(unlist(object@additional_stats)) > 0) {
      param_names <- h_summarize_add_stats(
        stats_list = object@additional_stats
      )[[1]]
      averages <- h_summarize_add_stats(stats_list = object@additional_stats)[[
        2
      ]]

      for (i in seq_along(param_names)) {
        cat(param_names[i], ":", round(averages[[i]], 2), "\n")
      }
    }

    # Report individual stopping rules with non-<NA> labels.

    stop_pct_to_print <- h_calc_report_label_percentage(object@stop_report)

    if (length(stop_pct_to_print) > 0) {
      cat(
        "Stop reason triggered:\n",
        paste(
          names(stop_pct_to_print),
          ": ",
          round(stop_pct_to_print, 2),
          "%\n"
        )
      )
    }

    ## and return the updated information
    names(r$df) <- r$dfNames
    invisible(r$df)
  }
)

##' Show the summary of the dual-endpoint simulations
##'
##' @param object the \code{\linkS4class{DualSimulationsSummary}} object we want
##' to print
##' @return invisibly returns a data frame of the results with one row and
##' appropriate column names
##'
##' @example examples/Simulations-method-show-DualSimulationsSummary.R
##' @export
##' @keywords methods
setMethod(
  "show",
  signature = signature(object = "DualSimulationsSummary"),
  def = function(object) {
    ## call the parent method
    df <- callNextMethod(object)
    dfNames <- names(df)

    ## start report object
    r <- Report$new(
      object = object,
      df = df,
      dfNames = dfNames
    )

    ## add one reporting line
    r$report(
      "biomarker_fit_at_dose_most_selected",
      "Fitted biomarker level at dose most often selected",
      percent = FALSE,
      digits = 1
    )

    ## and return the updated information
    names(r$df) <- r$dfNames
    invisible(r$df)
  }
)


##' Graphical display of the general simulation summary
##'
##' This plot method can be applied to
##' \code{\linkS4class{GeneralSimulationsSummary}} objects in order to
##' summarize them graphically. Possible \code{type}s of plots at the moment
##' are:
##'
##' \describe{
##' \item{nObs}{Distribution of the number of patients in the simulated trials}
##' \item{doseSelected}{Distribution of the final selected doses in the trials.
##' Note that this can include zero entries, meaning that the trial was stopped
##' because all doses in the dose grid appeared too toxic.}
##' \item{propDLTs}{Distribution of the proportion of patients with DLTs in the
##' trials}
##' \item{nAboveTarget}{Distribution of the number of patients treated at doses
##' which are above the target toxicity interval (as specified by the
##' \code{truth} and \code{target} arguments to
##' \code{\link{summary,GeneralSimulations-method}})}
##' }
##' You can specify any subset of these in the \code{type} argument.
##'
##' @param x the \code{\linkS4class{GeneralSimulationsSummary}} object we want
##' to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a `gtable` object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##' @export
##' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "GeneralSimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLTs",
      "nAboveTarget"
    ),
    ...
  ) {
    ## which plots should be produced?
    type <- match.arg(type, several.ok = TRUE)
    stopifnot(length(type) > 0L)

    ## start the plot list
    plotList <- list()
    plotIndex <- 0L

    ## distribution of overall sample size
    if (x@placebo) {
      if ("nObs" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@n_obs[2, ],
            description = "Number of patients on active in total"
          )
      }
    } else {
      if ("nObs" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@n_obs,
            description = "Number of patients in total"
          )
      }
    }

    ## distribution of final MTD estimate
    if ("doseSelected" %in% type) {
      plotList[[plotIndex <- plotIndex + 1L]] <-
        h_barplot_percentages(
          x = x@dose_selected,
          description = "MTD estimate"
        )
    }

    ## distribution of proportion of DLTs
    if (x@placebo) {
      if ("propDLTs" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@prop_dlts[1, ] * 100,
            description = "Proportion of DLTs [%] on active",
            xaxisround = 1
          )
      }
    } else {
      if ("propDLTs" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@prop_dlts * 100,
            description = "Proportion of DLTs [%]",
            xaxisround = 1
          )
      }
    }

    ## distribution of number of patients treated at too much tox
    if ("nAboveTarget" %in% type) {
      plotList[[plotIndex <- plotIndex + 1L]] <-
        h_barplot_percentages(
          x = x@n_above_target,
          description = "Number of patients above target"
        )
    }

    ## first combine these small plots
    if (length(plotList)) {
      ret <-
        ## if there is only one plot
        if (
          identical(
            length(plotList),
            1L
          )
        ) {
          ## just use that
          plotList[[1L]]
        } else {
          ## multiple plots in this case
          do.call(
            gridExtra::arrangeGrob,
            plotList
          )
        }
    }

    ## then return
    ret
  }
)


##' Plot summaries of the model-based design simulations
##'
##' Graphical display of the simulation summary
##'
##' This plot method can be applied to \code{\linkS4class{SimulationsSummary}}
##' objects in order to summarize them graphically. Possible \code{type} of
##' plots at the moment are those listed in
##' \code{\link{plot,GeneralSimulationsSummary,missing-method}} plus:
##' \describe{
##' \item{meanFit}{Plot showing the average fitted dose-toxicity curve across
##' the trials, together with 95% credible intervals, and comparison with the
##' assumed truth (as specified by the \code{truth} argument to
##' \code{\link{summary,Simulations-method}})}
##' }
##' You can specify any subset of these in the \code{type} argument.
##'
##' @param x the \code{\linkS4class{SimulationsSummary}} object we want
##' to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a `gtable` object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plot-SimulationsSummary.R
##' @export
##' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "SimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLTs",
      "nAboveTarget",
      "meanFit"
    ),
    ...
  ) {
    ## which plots should be produced?
    type <- match.arg(type, several.ok = TRUE)
    stopifnot(length(type) > 0L)

    ## substract the specific plot types for model-based
    ## designs
    typeReduced <- setdiff(
      type,
      "meanFit"
    )

    ## are there more plots from general?
    moreFromGeneral <- (length(typeReduced) > 0)

    ## if so, then produce these plots
    if (moreFromGeneral) {
      ret <- callNextMethod(x = x, y = y, type = typeReduced)
    }

    ## is the meanFit plot requested?
    if ("meanFit" %in% type) {
      ## which types of lines do we have?
      linetype <- c(
        "True toxicity",
        "Average estimated toxicity",
        "95% interval for estimated toxicity"
      )

      ## create the data frame, with
      ## true tox, average estimated tox, and 95% (lower, upper)
      ## estimated tox (in percentage) stacked below each other
      dat <- data.frame(
        dose = rep(x@dose_grid, 4L),
        group = rep(1:4, each = length(x@dose_grid)),
        linetype = factor(
          rep(linetype[c(1, 2, 3, 3)], each = length(x@dose_grid)),
          levels = linetype
        ),
        lines = unlist(x@mean_fit) * 100
      )

      ## linetypes for the plot
      lt <- c(
        "True toxicity" = 1,
        "Average estimated toxicity" = 1,
        "95% interval for estimated toxicity" = 2
      )

      ## colour for the plot
      col <- c(
        "True toxicity" = 1,
        "Average estimated toxicity" = 2,
        "95% interval for estimated toxicity" = 2
      )

      ## now create and save the plot
      thisPlot <- ggplot() +
        geom_line(
          aes(
            x = dose,
            y = lines,
            group = group,
            linetype = linetype,
            col = linetype
          ),
          data = dat
        )

      thisPlot <- thisPlot +
        scale_linetype_manual(values = lt) +
        scale_colour_manual(values = col) +
        xlab("Dose level") +
        ylab("Probability of DLT [%]")

      ## add this plot to the bottom
      ret <-
        if (moreFromGeneral) {
          gridExtra::arrangeGrob(ret, thisPlot)
        } else {
          thisPlot
        }
    }

    ## then finally plot everything
    ret
  }
)


##' Plot summaries of the dual-endpoint design simulations
##'
##' This plot method can be applied to \code{\linkS4class{DualSimulationsSummary}}
##' objects in order to summarize them graphically. Possible \code{type} of
##' plots at the moment are those listed in
##' \code{\link{plot,SimulationsSummary,missing-method}} plus:
##' \describe{
##' \item{meanBiomarkerFit}{Plot showing the average fitted dose-biomarker curve across
##' the trials, together with 95% credible intervals, and comparison with the
##' assumed truth (as specified by the \code{trueBiomarker} argument to
##' \code{\link{summary,DualSimulations-method}})}
##' }
##' You can specify any subset of these in the \code{type} argument.
##'
##' @param x the \code{\linkS4class{DualSimulationsSummary}} object we want
##' to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a `gtable` object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plot-DualSimulationsSummary.R
##' @export
##' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "DualSimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLTs",
      "nAboveTarget",
      "meanFit",
      "meanBiomarkerFit"
    ),
    ...
  ) {
    ## which plots should be produced?
    type <- match.arg(type, several.ok = TRUE)
    stopifnot(length(type) > 0L)

    ## substract the specific plot types for dual-endpoint
    ## designs
    typeReduced <- setdiff(
      type,
      "meanBiomarkerFit"
    )

    ## are there more plots from general?
    moreFromGeneral <- (length(typeReduced) > 0)

    ## if so, then produce these plots
    if (moreFromGeneral) {
      ret <- callNextMethod(x = x, y = y, type = typeReduced)
    }

    ## is the meanBiomarkerFit plot requested?
    if ("meanBiomarkerFit" %in% type) {
      ## which types of lines do we have?
      linetype <- c(
        "True biomarker",
        "Average estimated biomarker",
        "95% interval for estimated biomarker"
      )

      ## create the data frame, with
      ## true biomarker, average estimated biomarker, and 95% (lower, upper)
      ## estimated biomarker stacked below each other
      dat <- data.frame(
        dose = rep(x@dose_grid, 4L),
        group = rep(1:4, each = length(x@dose_grid)),
        linetype = factor(
          rep(linetype[c(1, 2, 3, 3)], each = length(x@dose_grid)),
          levels = linetype
        ),
        lines = unlist(x@mean_biomarker_fit)
      )

      ## linetypes for the plot
      lt <- c(
        "True biomarker" = 1,
        "Average estimated biomarker" = 1,
        "95% interval for estimated biomarker" = 2
      )

      ## colour for the plot
      col <- c(
        "True biomarker" = 1,
        "Average estimated biomarker" = 2,
        "95% interval for estimated biomarker" = 2
      )

      ## now create and save the plot
      thisPlot <- ggplot() +
        geom_line(
          aes(
            x = dose,
            y = lines,
            group = group,
            linetype = linetype,
            col = linetype
          ),
          data = dat
        )

      thisPlot <- thisPlot +
        scale_linetype_manual(values = lt) +
        scale_colour_manual(values = col) +
        xlab("Dose level") +
        ylab("Biomarker level")

      ## add this plot to the bottom
      ret <-
        if (moreFromGeneral) {
          gridExtra::arrangeGrob(ret, thisPlot, heights = c(2 / 3, 1 / 3))
        } else {
          thisPlot
        }
    }

    ## then finally plot everything
    ret
  }
)


## --------------------------------------------------------------------------------------------------------
##' Summarize the simulations, relative to a given truth
##'
##' @param object the \code{\linkS4class{PseudoSimulations}} object we want to
##' summarize
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity
##' @param targetEndOfTrial the target probability of DLE wanted to achieve at the end of a trial
##' @param targetDuringTrial the target probability of DLE wanted to achieve during a trial
##'
##' @param \dots Additional arguments can be supplied here for \code{truth}
##' @return an object of class \code{\linkS4class{PseudoSimulationsSummary}}
##'
##' @example examples/Simulations-method-summarySIMsingle.R
##' @export
##' @keywords methods
setMethod(
  "summary",
  signature = signature(object = "PseudoSimulations"),
  def = function(
    object,
    truth,
    targetEndOfTrial = 0.3,
    targetDuringTrial = 0.35,
    ...
  ) {
    ## extract dose grid
    doseGrid <- object@data[[1]]@doseGrid

    ## evaluate true DLE at doseGrid
    trueDLE <- truth(doseGrid)

    ## Inverse function of the truth function
    inverse <- function(f, lower = -100, upper = 100) {
      function(y) {
        uniroot((function(x) f(x) - y), lower = lower, upper = upper)[1]
      }
    }

    ## Function to obtain corresponsing dose level given target prob
    TD <- inverse(truth, 0, max(doseGrid))

    ## Find the dose corresponding to the target dose during trial
    targetDoseEndOfTrial <- as.numeric(TD(targetEndOfTrial))

    ## Find the dose corresponding to the target does end of trial
    targetDoseDuringTrial <- as.numeric(TD(targetDuringTrial))

    ## Find the dose at doseGrid corresponding to the above two quantities
    targetDoseEndOfTrialAtDoseGrid <- doseGrid[max(which(
      targetDoseEndOfTrial - doseGrid >= 0
    ))]
    targetDoseDuringTrialAtDoseGrid <- doseGrid[max(which(
      targetDoseDuringTrial - doseGrid >= 0
    ))]

    ## A summary for all TDtargetEndOfTrial dose obtained
    TDEOTSummary <- summary(object@final_td_target_end_of_trial_estimates)

    FinalDoseRecSummary <- TDEOTSummary

    ratioTDEOTSummary <- summary(object@final_tdeot_ratios)
    FinalRatioSummary <- ratioTDEOTSummary

    ## A summary for all TDtargetDuringTrial dose obtained
    TDDTSummary <- summary(object@final_td_target_during_trial_estimates)
    ## what are the levels above target End of Trial?
    xAboveTargetEndOfTrial <- which(trueDLE > targetEndOfTrial)

    ## what are the levels above target During Trial?
    xAboveTargetDuringTrial <- which(trueDLE > targetDuringTrial)

    ## proportion of DLEs in this trial
    propDLE <- sapply(
      object@data,
      function(d) {
        mean(d@y)
      }
    )
    ### mean toxicity risk
    meanToxRisk <- sapply(
      object@data,
      function(d) {
        mean(trueDLE[d@xLevel])
      }
    )

    ## doses selected for MTD
    doseSelected <- object@doses

    ## replace NA by 0
    doseSelected[is.na(doseSelected)] <- 0

    ## dose most often selected as MTD
    doseMostSelected <-
      as.numeric(names(which.max(table(doseSelected))))

    # doseRec <- doseMostSelected

    xMostSelected <-
      match_within_tolerance(doseMostSelected, table = doseGrid)

    ## observed toxicity rate at dose most often selected
    ## Note: this does not seem very useful!
    ## Reason: In case of a fine grid, few patients if any
    ## will have been treated at this dose.
    tmp <-
      sapply(
        object@data,
        function(d) {
          whichAtThisDose <- which(d@x == doseMostSelected)
          nAtThisDose <- length(whichAtThisDose)
          nDLTatThisDose <- sum(d@y[whichAtThisDose])
          return(c(
            nAtThisDose = nAtThisDose,
            nDLTatThisDose = nDLTatThisDose
          ))
        }
      )

    obsToxRateAtDoseMostSelected <-
      mean(tmp["nDLTatThisDose", ]) / mean(tmp["nAtThisDose", ])

    ## number of patients overall
    nObs <- sapply(
      object@data,
      slot,
      "nObs"
    )

    ## number of patients treated above target End of trial
    nAboveTargetEndOfTrial <- sapply(
      object@data,
      function(d) {
        sum(d@xLevel %in% xAboveTargetEndOfTrial)
      }
    )

    ## number of patients treated above target During trial
    nAboveTargetDuringTrial <- sapply(
      object@data,
      function(d) {
        sum(d@xLevel %in% xAboveTargetDuringTrial)
      }
    )

    toxAtDoses <- truth(doseSelected)

    ## Proportion of trials selecting target TDEndOfTrial and TDDuringTrial
    nsim <- length(object@data)

    propAtTargetEndOfTrial <- (length(which(
      object@doses == targetDoseEndOfTrialAtDoseGrid
    ))) /
      nsim
    propAtTargetDuringTrial <- (length(which(
      object@doses == targetDoseDuringTrialAtDoseGrid
    ))) /
      nsim

    RecDoseSummary <- TDEOTSummary

    ## fitted probDLE at dose most often selected
    ## find names in the fit list (check it is with or without samples)
    FitNames <- sapply(object@fit, names)

    if ("probDLE" %in% FitNames) {
      fitAtDoseMostSelected <- sapply(
        object@fit,
        function(f) {
          f$probDLE[xMostSelected]
        }
      )
      meanFitMatrix <- sapply(
        object@fit,
        "[[",
        "probDLE"
      )

      meanFit <- list(
        truth = truth(doseGrid),
        average = rowMeans(meanFitMatrix)
      )
    } else {
      ## fitted toxicity rate at dose most often selected
      fitAtDoseMostSelected <-
        sapply(
          object@fit,
          function(f) {
            f$middle[xMostSelected]
          }
        )

      ## mean fitted toxicity (average, lower and upper quantiles)
      ## at each dose level
      ## (this is required for plotting)
      meanFitMatrix <- sapply(
        object@fit,
        "[[",
        "middle"
      )
      meanFit <- list(
        truth = truth(doseGrid),
        average = rowMeans(meanFitMatrix),
        lower = apply(
          meanFitMatrix,
          1L,
          quantile,
          0.025
        ),
        upper = apply(
          meanFitMatrix,
          1L,
          quantile,
          0.975
        )
      )
    }

    ## give back an object of class GeneralSimulationsSummary,
    ## for which we then define a print / plot method
    ret <- .PseudoSimulationsSummary(
      targetEndOfTrial = targetEndOfTrial,
      targetDoseEndOfTrial = targetDoseEndOfTrial,
      targetDuringTrial = targetDuringTrial,
      targetDoseDuringTrial = targetDoseDuringTrial,
      targetDoseEndOfTrialAtDoseGrid = targetDoseEndOfTrialAtDoseGrid,
      targetDoseDuringTrialAtDoseGrid = targetDoseDuringTrialAtDoseGrid,
      TDEOTSummary = TDEOTSummary,
      TDDTSummary = TDDTSummary,
      FinalDoseRecSummary = FinalDoseRecSummary,
      ratioTDEOTSummary = ratioTDEOTSummary,
      FinalRatioSummary = FinalRatioSummary,
      nsim = length(object@data),
      propDLE = propDLE,
      meanToxRisk = meanToxRisk,
      doseSelected = doseSelected,
      doseMostSelected = doseMostSelected,
      # doseRec=doseRec,
      obsToxRateAtDoseMostSelected = obsToxRateAtDoseMostSelected,
      nObs = nObs,
      nAboveTargetEndOfTrial = nAboveTargetEndOfTrial,
      nAboveTargetDuringTrial = nAboveTargetDuringTrial,
      toxAtDosesSelected = toxAtDoses,
      propAtTargetEndOfTrial = propAtTargetEndOfTrial,
      propAtTargetDuringTrial = propAtTargetDuringTrial,
      doseGrid = doseGrid,
      fitAtDoseMostSelected = fitAtDoseMostSelected,
      stop_report = object@stop_report,
      meanFit = meanFit
    )

    return(ret)
  }
)
## ========================================================================================================
##' Show the summary of the simulations
##'
##' @param object the \code{\linkS4class{PseudoSimulationsSummary}} object we want
##' to print
##' @return invisibly returns a data frame of the results with one row and
##' appropriate column names
##'
##' @example examples/Simulations-method-showSIMsingle.R
##' @export
##' @keywords methods

setMethod(
  "show",
  signature = signature(object = "PseudoSimulationsSummary"),
  def = function(object) {
    r <- Report$new(
      object = object,
      df = as.data.frame(matrix(
        nrow = 1,
        ncol = 0
      )),
      dfNames = character()
    )
    cat(
      "Summary of",
      r$dfSave(object@nsim, "nsim"),
      "simulations\n\n"
    )

    cat(
      "Target probability of DLE p(DLE) used at the end of a trial was",
      r$dfSave(
        object@targetEndOfTrial * 100,
        "targetEndOfTrial"
      ),
      "%\n"
    )

    cat(
      "The dose level corresponds to the target p(DLE) used at the end of a trial, TDEOT, was",
      r$dfSave(
        object@targetDoseEndOfTrial,
        "targetDoseEndOfTrial"
      ),
      "\n"
    )
    cat(
      "TDEOT at dose Grid was",
      r$dfSave(
        object@targetDoseEndOfTrialAtDoseGrid,
        "targetDoseEndOfTrialAtDoseGrid"
      ),
      "\n"
    )

    cat(
      "Target p(DLE) used during a trial was",
      r$dfSave(
        object@targetDuringTrial * 100,
        "targetDuringTrial"
      ),
      "%\n"
    )

    cat(
      "The dose level corresponds to the target p(DLE) used during a trial, TDDT, was",
      r$dfSave(
        object@targetDoseDuringTrial,
        "targetDoseDuringTrial"
      ),
      "\n"
    )

    cat(
      "TDDT at dose Grid was",
      r$dfSave(
        object@targetDoseDuringTrialAtDoseGrid,
        "targetDoseDuringTrialAtDoseGrid"
      ),
      "\n"
    )

    r$report("nObs", "Number of patients overall", percent = FALSE)
    r$report(
      "nAboveTargetEndOfTrial",
      "Number of patients treated above the target p(DLE) used at the end of a trial",
      percent = FALSE
    )

    r$report(
      "nAboveTargetDuringTrial",
      "Number of patients treated above the target p(DLE) used during a trial",
      percent = FALSE
    )

    r$report(
      "propDLE",
      "Proportions of observed DLT in the trials"
    )
    r$report(
      "meanToxRisk",
      "Mean toxicity risks for the patients"
    )
    r$report(
      "doseSelected",
      "Doses selected as TDEOT",
      percent = FALSE,
      digits = 1
    )
    # r$report("doseRec",
    #         "Doses to recommend to subsequent study",
    #         percent=FALSE, digits=1)

    r$report(
      "toxAtDosesSelected",
      "True toxicity at TDEOT"
    )

    cat(
      "Proportion of trials selecting the TDEOT:",
      r$dfSave(
        object@propAtTargetEndOfTrial * 100,
        "percentAtTarget"
      ),
      "%\n"
    )

    cat(
      "Proportion of trials selecting the TDDT:",
      r$dfSave(
        object@propAtTargetDuringTrial * 100,
        "percentAtTarget"
      ),
      "%\n"
    )

    cat(
      "Dose most often selected as TDEOT:",
      r$dfSave(
        object@doseMostSelected,
        "doseMostSelected"
      ),
      "\n"
    )
    cat(
      "Observed toxicity rate at dose most often selected:",
      r$dfSave(
        round(object@obsToxRateAtDoseMostSelected * 100),
        "obsToxRateAtDoseMostSelected"
      ),
      "%\n"
    )
    r$report(
      "fitAtDoseMostSelected",
      "Fitted probabilities of DLE at dose most often selected"
    )

    TDEOTSum <- object@TDEOTSummary

    r$dfSave(as.numeric(TDEOTSum[1]), "TDEOTMin")
    r$dfSave(as.numeric(TDEOTSum[2]), "TDEOTlower")
    r$dfSave(as.numeric(TDEOTSum[3]), "TDEOTMedian")
    r$dfSave(as.numeric(TDEOTSum[4]), "TDEOTMean")
    r$dfSave(as.numeric(TDEOTSum[5]), "TDEOTUpper")
    r$dfSave(as.numeric(TDEOTSum[6]), "TDEOTMax")

    cat(
      "The summary table of the final TDEOT across all simulations\n",
      capture.output(TDEOTSum)[1],
      "\n",
      capture.output(TDEOTSum)[2],
      "\n"
    )

    ratioTDEOTSum <- object@ratioTDEOTSummary

    r$dfSave(as.numeric(ratioTDEOTSum[1]), "ratioTDEOTMin")
    r$dfSave(as.numeric(ratioTDEOTSum[2]), "ratioTDEOTlower")
    r$dfSave(as.numeric(ratioTDEOTSum[3]), "ratioTDEOTMedian")
    r$dfSave(as.numeric(ratioTDEOTSum[4]), "ratioTDEOTMean")
    r$dfSave(as.numeric(ratioTDEOTSum[5]), "ratioTDEOTUpper")
    r$dfSave(as.numeric(ratioTDEOTSum[6]), "ratioTDEOTMax")

    cat(
      "The summary table of the final ratios of the TDEOT across all simulations\n",
      capture.output(ratioTDEOTSum)[1],
      "\n",
      capture.output(ratioTDEOTSum)[2],
      "\n"
    )

    TDDTSum <- object@TDDTSummary

    r$dfSave(as.numeric(TDDTSum[1]), "TDDTMin")
    r$dfSave(as.numeric(TDDTSum[2]), "TDDTlower")
    r$dfSave(as.numeric(TDDTSum[3]), "TDDTMedian")
    r$dfSave(as.numeric(TDDTSum[4]), "TDDTMean")
    r$dfSave(as.numeric(TDDTSum[5]), "TDDTUpper")
    r$dfSave(as.numeric(TDDTSum[6]), "TDDTMax")

    cat(
      "The summary table of the final TDDT across all simulations\n",
      capture.output(TDDTSum)[1],
      "\n",
      capture.output(TDDTSum)[2],
      "\n"
    )

    FinalDoseRecSum <- object@FinalDoseRecSummary

    r$dfSave(as.numeric(FinalDoseRecSum[1]), "FinalDoseRecMin")
    r$dfSave(as.numeric(FinalDoseRecSum[2]), "FinalDoseReclower")
    r$dfSave(as.numeric(FinalDoseRecSum[3]), "FinalDoseRecMedian")
    r$dfSave(as.numeric(FinalDoseRecSum[4]), "FinalDoseRecMean")
    r$dfSave(as.numeric(FinalDoseRecSum[5]), "FinalDoseRecUpper")
    r$dfSave(as.numeric(FinalDoseRecSum[6]), "FinalDoseRecMax")

    cat(
      "The summary table of dose levels, the optimal dose\n to recommend for subsequent study across all simulations\n",
      capture.output(FinalDoseRecSum)[1],
      "\n",
      capture.output(FinalDoseRecSum)[2],
      "\n"
    )

    FinalratioSum <- object@FinalRatioSummary

    r$dfSave(as.numeric(FinalratioSum[1]), "FinalratioMin")
    r$dfSave(as.numeric(FinalratioSum[2]), "Finalratiolower")
    r$dfSave(as.numeric(FinalratioSum[3]), "FinalratioMedian")
    r$dfSave(as.numeric(FinalratioSum[4]), "FinalratioMean")
    r$dfSave(as.numeric(FinalratioSum[5]), "FinalratioUpper")
    r$dfSave(as.numeric(FinalratioSum[6]), "FinalratioMax")

    cat(
      "The summary table of the final ratios of the optimal dose for stopping across
                  all simulations\n",
      capture.output(FinalratioSum)[1],
      "\n",
      capture.output(FinalratioSum)[2],
      "\n\n"
    )

    # Report individual stopping rules with non-<NA> labels.

    stop_pct_to_print <- h_calc_report_label_percentage(object@stop_report)

    if (length(stop_pct_to_print) > 0) {
      cat(
        "Stop reason triggered:\n",
        paste(names(stop_pct_to_print), ": ", stop_pct_to_print, "%\n")
      )
    }

    ## finally assign names to the df
    ## and return it invisibly
    names(r$df) <- r$dfNames
    invisible(r$df)
  }
)
## -------------------------------------------------------------------------------------------
##' Plot summaries of the pseudo simulations
##'
##' Graphical display of the simulation summary
##'
##' This plot method can be applied to \code{\linkS4class{PseudoSimulationsSummary}}
##' objects in order to summarize them graphically. This can be used when only DLE responses are involved
##' in the simulations. This also applied to results with or without samples generated during the simulations
##'
##' @param x the \code{\linkS4class{PseudoSimulationsSummary}} object we want
##' to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a `gtable` object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSUMsingle.R
##' @export
##' @keywords methods
##'

setMethod(
  "plot",
  signature = signature(
    x = "PseudoSimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLE",
      "nAboveTargetEndOfTrial",
      "meanFit"
    ),
    ...
  ) {
    ## which plots should be produced?
    type <- match.arg(type, several.ok = TRUE)
    stopifnot(length(type) > 0L)

    ## start the plot list
    plotList <- list()
    plotIndex <- 0L

    ## distribution of overall sample size
    if ("nObs" %in% type) {
      plotList[[plotIndex <- plotIndex + 1L]] <-
        h_barplot_percentages(
          x = x@nObs,
          description = "Number of patients in total"
        )
    }

    ## distribution of final MTD estimate
    if ("doseSelected" %in% type) {
      plotList[[plotIndex <- plotIndex + 1L]] <-
        h_barplot_percentages(
          x = x@doseSelected,
          description = "MTD estimate"
        )
    }

    ## distribution of proportion of DLTs
    if ("propDLE" %in% type) {
      plotList[[plotIndex <- plotIndex + 1L]] <-
        h_barplot_percentages(
          x = x@propDLE * 100,
          description = "Proportion of DLE [%]",
          xaxisround = 1
        )
    }

    ## distribution of number of patients treated at too much tox
    if ("nAboveTargetEndOfTrial" %in% type) {
      plotList[[plotIndex <- plotIndex + 1L]] <-
        h_barplot_percentages(
          x = x@nAboveTargetEndOfTrial,
          description = "Number of patients above target"
        )
    }

    ## first combine these small plots
    if (length(plotList)) {
      ret <-
        ## if there is only one plot
        if (
          identical(
            length(plotList),
            1L
          )
        ) {
          ## just use that
          plotList[[1L]]
        } else {
          ## multiple plots in this case
          do.call(
            gridExtra::arrangeGrob,
            plotList
          )
        }
    }

    ## the meanFit plot

    if ("meanFit" %in% type) {
      ## Find if DLE samples are generated in the simulations
      ## by checking if there the lower limits of the 95% Credibility
      ## interval are calculated
      if (!is.null(x@meanFit$lower)) {
        ## which types of lines do we have?
        linetype <- c(
          "True toxicity",
          "Average estimated toxicity",
          "95% interval for estimated toxicity"
        )
        ## create the data frame, with
        ## true tox, average estimated tox, and 95% (lower, upper)
        ## estimated tox (in percentage) stacked below each other
        dat <- data.frame(
          dose = rep(x@doseGrid, 4L),
          group = rep(1:4, each = length(x@doseGrid)),
          linetype = factor(
            rep(linetype[c(1, 2, 3, 3)], each = length(x@doseGrid)),
            levels = linetype
          ),
          lines = unlist(x@meanFit) * 100
        )

        ## linetypes for the plot
        lt <- c(
          "True toxicity" = 1,
          "Average estimated toxicity" = 1,
          "95% interval for estimated toxicity" = 2
        )

        ## colour for the plot
        col <- c(
          "True toxicity" = 1,
          "Average estimated toxicity" = 2,
          "95% interval for estimated toxicity" = 2
        )

        ## now create and save the plot
        thisPlot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        thisPlot <- thisPlot +
          scale_linetype_manual(values = lt) +
          scale_colour_manual(values = col) +
          xlab("Dose level") +
          ylab("Probability of DLE [%]")
      } else {
        ## which types of lines do we have?
        linetype <- c(
          "True toxicity",
          "Average estimated toxicity"
        )

        ## create the data frame, with
        ## true tox, average estimated tox
        ## estimated tox (in percentage) stacked below each other
        dat <- data.frame(
          dose = rep(x@doseGrid, 2L),
          group = rep(1:2, each = length(x@doseGrid)),
          linetype = factor(
            rep(linetype[c(1, 2)], each = length(x@doseGrid)),
            levels = linetype
          ),
          lines = unlist(x@meanFit) * 100
        )

        ## linetypes for the plot
        lt <- c(
          "True toxicity" = 1,
          "Average estimated toxicity" = 1
        )

        ## colour for the plot
        col <- c(
          "True toxicity" = 1,
          "Average estimated toxicity" = 2
        )

        ## now create and save the plot
        thisPlot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        thisPlot <- thisPlot +
          scale_linetype_manual(values = lt) +
          scale_colour_manual(values = col) +
          xlab("Dose level") +
          ylab("Probability of DLE [%]")
      }
    }

    ## then add this plot at the bottom
    ret <- gridExtra::arrangeGrob(ret, thisPlot)
    ret
  }
)
## --------------------------------------------------------------------------------------
##' Plot simulations
##'
##' Summarize the simulations with plots
##'
##' This plot method can be applied to \code{\linkS4class{PseudoDualSimulations}}
##' objects in order to summarize them graphically. Possible \code{type}s of
##' plots at the moment are: \describe{ \item{trajectory}{Summary of the
##' trajectory of the simulated trials} \item{dosesTried}{Average proportions of
##' the doses tested in patients} \item{sigma2}{The variance of the efficacy responses}}
##' You can specify one or both of these in the
##' \code{type} argument.
##'
##' @param x the \code{\linkS4class{PseudoDualSimulations}} object we want
##' to plot from
##' @param y missing
##' @param type the type of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a `gtable` object.
##'
##' @importFrom ggplot2 ggplot geom_step geom_bar aes xlab ylab
##' scale_linetype_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSIMDual.R
##' @export
##' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "PseudoDualSimulations",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "trajectory",
      "dosesTried",
      "sigma2"
    ),
    ...
  ) {
    ## start the plot list
    plotList <- list()
    plotIndex <- 0L

    ## which plots should be produced?
    type <- match.arg(type, several.ok = TRUE)
    stopifnot(length(type) > 0L)

    ## substract the specific plot types for
    ## dual-endpoint simulation results
    typeReduced <- setdiff(
      type,
      "sigma2"
    )

    ## are there more plots from general?
    moreFromGeneral <- (length(typeReduced) > 0)

    ## if so, then produce these plots
    if (moreFromGeneral) {
      genPlot <- callNextMethod(x = x, y = y, type = typeReduced)
    }

    ## now to the specific dual-endpoint plots:

    ## Efficacy variance estimates boxplot
    if ("sigma2" %in% type) {
      ## save the plot
      plotList[[plotIndex <- plotIndex + 1L]] <-
        qplot(
          factor(0),
          y = y,
          data = data.frame(y = x@sigma2_est),
          geom = "boxplot",
          xlab = "",
          ylab = "Efficacy variance estimates"
        ) +
        coord_flip() +
        scale_x_discrete(breaks = NULL)
    }

    ## then finally plot everything
    if (
      identical(
        length(plotList),
        0L
      )
    ) {
      return(genPlot)
    } else if (
      identical(
        length(plotList),
        1L
      )
    ) {
      ret <- plotList[[1L]]
    } else {
      ret <- do.call(
        gridExtra::arrangeGrob,
        plotList
      )
    }

    if (moreFromGeneral) {
      ret <- gridExtra::arrangeGrob(genPlot, ret, heights = c(2 / 3, 1 / 3))
    }

    return(ret)
  }
)
## ---------------------------------------------------------------------------------
##'
##' This plot method can be applied to \code{\linkS4class{PseudoDualFlexiSimulations}}
##' objects in order to summarize them graphically. Possible \code{type}s of
##' plots at the moment are: \describe{ \item{trajectory}{Summary of the
##' trajectory of the simulated trials} \item{dosesTried}{Average proportions of
##' the doses tested in patients} \item{sigma2}{The variance of the efficacy responses}
##' \item{sigma2betaW}{The variance of the random walk model}}
##' You can specify one or both of these in the
##' \code{type} argument.
##'
##' @param x the \code{\linkS4class{PseudoDualFlexiSimulations}} object we want
##' to plot from
##' @param y missing
##' @param type the type of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a `gtable` object.
##'
##' @importFrom ggplot2 ggplot geom_step geom_bar aes xlab ylab
##' scale_linetype_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSIMDualFlexi.R
##' @export
##' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "PseudoDualFlexiSimulations",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "trajectory",
      "dosesTried",
      "sigma2",
      "sigma2betaW"
    ),
    ...
  ) {
    ## start the plot list
    plotList <- list()
    plotIndex <- 0L

    ## which plots should be produced?
    type <- match.arg(type, several.ok = TRUE)
    stopifnot(length(type) > 0L)

    ## substract the specific plot types for
    ## dual-endpoint simulation results
    typeReduced <- setdiff(type, "sigma2betaW")

    ## are there more plots from general?
    moreFromGeneral <- (length(typeReduced) > 0)

    ## if so, then produce these plots
    if (moreFromGeneral) {
      genPlot <- callNextMethod(x = x, y = y, type = typeReduced)
    }

    ## now to the specific dual-endpoint plots:
    ## random walk model variance estimates boxplot

    if ("sigma2betaW" %in% type) {
      ## save the plot
      plotList[[plotIndex <- plotIndex + 1L]] <-
        qplot(
          factor(0),
          y = y,
          data = data.frame(y = x@sigma2_beta_w_est),
          geom = "boxplot",
          xlab = "",
          ylab = "Random walk model variance estimates"
        ) +
        coord_flip() +
        scale_x_discrete(breaks = NULL)
    }

    ## then finally plot everything
    if (
      identical(
        length(plotList),
        0L
      )
    ) {
      return(genPlot)
    } else if (
      identical(
        length(plotList),
        1L
      )
    ) {
      ret <- plotList[[1L]]
    } else {
      ret <- do.call(
        gridExtra::arrangeGrob,
        plotList
      )
    }

    if (moreFromGeneral) {
      ret <- gridExtra::arrangeGrob(genPlot, ret, heights = c(2 / 3, 1 / 3))
    }

    return(ret)
  }
)

## -----------------------------------------------------------------------------------------
##' Summary for Pseudo Dual responses simulations, relative to a given pseudo DLE and efficacy model
##' (except the EffFlexi class model)
##'
##' @param object the \code{\linkS4class{PseudoDualSimulations}} object we want to summarize
##' @param trueDLE a function which takes as input a dose (vector) and returns the true probability (vector)
##' of DLE
##' @param trueEff a function which takes as input a dose (vector) and returns the mean efficacy value(s) (vector).
##' @param targetEndOfTrial the target probability of DLE that are used at the end of a trial. Default at 0.3.
##' @param targetDuringTrial the target probability of DLE that are used during the trial. Default at 0.35.
##' @param \dots Additional arguments can be supplied here for \code{trueDLE} and \code{trueEff}
##' @return an object of class \code{\linkS4class{PseudoDualSimulationsSummary}}
##'
##' @example examples/Simulations-method-summarySIMDual.R
##' @export
##' @keywords methods
setMethod(
  "summary",
  signature = signature(object = "PseudoDualSimulations"),
  def = function(
    object,
    trueDLE,
    trueEff,
    targetEndOfTrial = 0.3,
    targetDuringTrial = 0.35,
    ...
  ) {
    ## call the parent method
    start <- callNextMethod(
      object = object,
      truth = trueDLE,
      targetEndOfTrial = targetEndOfTrial,
      targetDuringTrial = targetDuringTrial,
      ...
    )
    doseGrid <- object@data[[1]]@doseGrid

    ## ## dose level most often selected as MTD (TDtargetEnd of Trial)
    xMostSelected <-
      match_within_tolerance(start@doseMostSelected, table = doseGrid)

    ## check if true Eff is a function
    ## check if special case applies
    isTrueEffFx <- is.function(trueEff)

    TDtargetEndOfTrial <- start@targetDoseEndOfTrial

    if (isTrueEffFx) {
      negtrueGainfn <- function(dose) {
        return(-(trueEff(dose)) / (1 + (trueDLE(dose) / (1 - trueDLE(dose)))))
      }
      Gstar <- optim(exp(1), negtrueGainfn, method = "BFGS")$par
      maxGainValue <- -(optim(exp(1), negtrueGainfn, method = "BFGS")$value)
      GstarAtDoseGrid <- doseGrid[max(which(Gstar - doseGrid >= 0))]
    } else {
      trueGain <- (trueEff) /
        (1 + (trueDLE(doseGrid) / (1 - trueDLE(doseGrid))))
      maxGainValue <- max(trueGain)
      Gstar <- doseGrid[which.max(trueGain)]
      GstarAtDoseGrid <- Gstar
    }

    ## A summary for all final Gstar obtained
    GstarSummary <- summary(object@final_gstar_estimates)
    ratioGstarSummary <- summary(object@final_gstar_ratios)

    FinalDoseRecSummary <- summary(object@final_optimal_dose)
    FinalRatioSummary <- summary(object@final_ratios)

    ## find names in the fit efficacy list (check it is with or without samples)
    FitNames <- sapply(object@fit_eff, names)
    if ("ExpEff" %in% FitNames) {
      ## fitted efficacy level at dose most often selected
      EffFitAtDoseMostSelected <- sapply(
        object@fit_eff,
        function(f) {
          f$ExpEff[xMostSelected]
        }
      )
      meanEffFitMatrix <- sapply(
        object@fit_eff,
        "[[",
        "ExpEff"
      )

      meanEffFit <- list(
        truth = trueEff(doseGrid),
        average = rowMeans(meanEffFitMatrix)
      )
    } else {
      ## fitted efficacy level at dose most often selected
      EffFitAtDoseMostSelected <-
        sapply(
          object@fit_eff,
          function(f) {
            f$middle[xMostSelected]
          }
        )

      ## mean fitted  curve (average, lower and upper quantiles)
      ## at each dose level
      ## (this is required for plotting)
      meanEffFitMatrix <- sapply(
        object@fit_eff,
        "[[",
        "middle"
      )

      ## check if special case applies

      if (isTrueEffFx) {
        TRUTHeff <- trueEff(doseGrid)
      } else {
        TRUTHeff <- trueEff
      }

      meanEffFit <- list(
        truth = TRUTHeff,
        average = rowMeans(meanEffFitMatrix),
        lower = apply(
          meanEffFitMatrix,
          1L,
          quantile,
          0.025
        ),
        upper = apply(
          meanEffFitMatrix,
          1L,
          quantile,
          0.975
        )
      )
    }

    ## give back an object of class PseudoDualSimulationsSummary,
    ## for which we then define a print / plot method
    ret <- .PseudoDualSimulationsSummary(
      start,
      targetGstar = Gstar,
      targetGstarAtDoseGrid = GstarAtDoseGrid,
      GstarSummary = GstarSummary,
      ratioGstarSummary = ratioGstarSummary,
      FinalDoseRecSummary = FinalDoseRecSummary,
      FinalRatioSummary = FinalRatioSummary,
      EffFitAtDoseMostSelected = EffFitAtDoseMostSelected,
      meanEffFit = meanEffFit,
      stop_report = object@stop_report
    )

    return(ret)
  }
)
## --------------------------------------------------------------------------------------------------
##' Summary for Pseudo Dual responses simulations given a pseudo DLE model and the Flexible efficacy model.
##'
##' @param object the \code{\linkS4class{PseudoDualFlexiSimulations}} object we want to summarize
##' @param trueDLE a function which takes as input a dose (vector) and returns the true probability of DLE (vector)
##' @param trueEff a vector which takes as input the true mean efficacy values at all dose levels (in order)
##' @param targetEndOfTrial the target probability of DLE that are used at the end of a trial. Default at 0.3.
##' @param targetDuringTrial the target probability of DLE that are used during the trial. Default at 0.35.
##' @param \dots Additional arguments can be supplied here for \code{trueDLE} and \code{trueEff}
##' @return an object of class \code{\linkS4class{PseudoDualSimulationsSummary}}
##'
##' @example examples/Simulations-method-summarySIMDualFlexi.R
##' @export
##' @keywords methods
setMethod(
  "summary",
  signature = signature(object = "PseudoDualFlexiSimulations"),
  def = function(
    object,
    trueDLE,
    trueEff,
    targetEndOfTrial = 0.3,
    targetDuringTrial = 0.35,
    ...
  ) {
    ## call the parent method
    start <- callNextMethod(
      object = object,
      trueDLE = trueDLE,
      trueEff = trueEff,
      targetEndOfTrial = targetEndOfTrial,
      targetDuringTrial = targetDuringTrial,
      ...
    )

    ## give back an object of class PseudoDualSimulationsSummary,
    ## for which we then define a print / plot method
    ret <- .PseudoDualSimulationsSummary(start)

    return(ret)
  }
)

## ----------------------------------------------------------------------------------------
##' Show the summary of Pseudo Dual simulations summary
##'
##' @param object the \code{\linkS4class{PseudoDualSimulationsSummary}} object we want to print
##' @return invisibly returns a data frame of the results with one row and appropriate column names
##'
##'
##' @example examples/Simulations-method-showSIMDual.R
##' @export
##' @keywords methods
setMethod(
  "show",
  signature = signature(object = "PseudoDualSimulationsSummary"),
  def = function(object) {
    ## call the parent method
    df <- callNextMethod(object)
    dfNames <- names(df)

    ## start report object
    r <- Report$new(
      object = object,
      df = df,
      dfNames = dfNames
    )

    ## add three reporting lines
    cat(
      "Target Gstar, the dose which gives the maximum gain value was",
      r$dfSave(
        object@targetGstar,
        "targetGstar"
      ),
      "\n"
    )
    cat(
      "Target Gstar at dose Grid was",
      r$dfSave(
        object@targetGstarAtDoseGrid,
        "targetGstarAtDoseGrid"
      ),
      "\n"
    )

    GstarSum <- object@GstarSummary

    r$dfSave(as.numeric(GstarSum[1]), "GstarMin")
    r$dfSave(as.numeric(GstarSum[2]), "Gstarlower")
    r$dfSave(as.numeric(GstarSum[3]), "GstarMedian")
    r$dfSave(as.numeric(GstarSum[4]), "GstarMean")
    r$dfSave(as.numeric(GstarSum[5]), "GstarUpper")
    r$dfSave(as.numeric(GstarSum[6]), "GstarMax")

    cat(
      "The summary table of the final Gstar across all simulations\n",
      capture.output(GstarSum)[1],
      "\n",
      capture.output(GstarSum)[2],
      "\n"
    )

    ratioGstarSum <- object@ratioGstarSummary

    r$dfSave(as.numeric(ratioGstarSum[1]), "ratioGstarMin")
    r$dfSave(as.numeric(ratioGstarSum[2]), "ratioGstarlower")
    r$dfSave(as.numeric(ratioGstarSum[3]), "ratioGstarMedian")
    r$dfSave(as.numeric(ratioGstarSum[4]), "ratioGstarMean")
    r$dfSave(as.numeric(ratioGstarSum[5]), "ratioGstarUpper")
    r$dfSave(as.numeric(ratioGstarSum[6]), "ratioGstarMax")

    cat(
      "The summary table of the final ratios of the Gstar across all simulations\n",
      capture.output(ratioGstarSum)[1],
      "\n",
      capture.output(ratioGstarSum)[2],
      "\n"
    )

    FinalDoseRecSum <- object@FinalDoseRecSummary

    r$dfSave(as.numeric(FinalDoseRecSum[1]), "FinalDoseRecMin")
    r$dfSave(as.numeric(FinalDoseRecSum[2]), "FinalDoseReclower")
    r$dfSave(as.numeric(FinalDoseRecSum[3]), "FinalDoseRecMedian")
    r$dfSave(as.numeric(FinalDoseRecSum[4]), "FinalDoseRecMean")
    r$dfSave(as.numeric(FinalDoseRecSum[5]), "FinalDoseRecUpper")
    r$dfSave(as.numeric(FinalDoseRecSum[6]), "FinalDoseRecMax")

    cat(
      "The summary table of dose levels, the optimal dose\n to recommend for subsequent study across all simulations\n",
      capture.output(FinalDoseRecSum)[1],
      "\n",
      capture.output(FinalDoseRecSum)[2],
      "\n"
    )

    FinalratioSum <- object@FinalRatioSummary

    r$dfSave(as.numeric(FinalratioSum[1]), "FinalratioMin")
    r$dfSave(as.numeric(FinalratioSum[2]), "Finalratiolower")
    r$dfSave(as.numeric(FinalratioSum[3]), "FinalratioMedian")
    r$dfSave(as.numeric(FinalratioSum[4]), "FinalratioMean")
    r$dfSave(as.numeric(FinalratioSum[5]), "FinalratioUpper")
    r$dfSave(as.numeric(FinalratioSum[6]), "FinalratioMax")

    cat(
      "The summary table of the final ratios of the optimal dose for stopping across
        all simulations\n",
      capture.output(FinalratioSum)[1],
      "\n",
      capture.output(FinalratioSum)[2],
      "\n"
    )

    r$report(
      "EffFitAtDoseMostSelected",
      "Fitted expected efficacy level at dose most often selected",
      percent = FALSE,
      digits = 1
    )

    # Report individual stopping rules with non-<NA> labels.

    stop_pct_to_print <- h_calc_report_label_percentage(object@stop_report)

    if (length(stop_pct_to_print) > 0) {
      cat(
        "Stop reason triggered:\n",
        paste(names(stop_pct_to_print), ": ", stop_pct_to_print, "%\n")
      )
    }

    ## and return the updated information
    names(r$df) <- r$dfNames
    invisible(r$df)
  }
)

## --------------------------------------------------------------------------------------------------
##' Plot the summary of Pseudo Dual Simulations summary
##'
##' This plot method can be applied to \code{\linkS4class{PseudoDualSimulationsSummary}} objects in order
##' to summarize them graphically. Possible \code{type} of plots at the moment are those listed in
##' \code{\link{plot,PseudoSimulationsSummary,missing-method}} plus:
##' \describe{\item{meanEffFit}{Plot showing the fitted dose-efficacy curve. If no samples are involved, only the
##' average fitted dose-efficacy curve across the trials will be plotted. If samples (DLE and efficacy) are involved,
##' the average fitted dose-efficacy curve across the trials, together with the 95% credibility interval; and comparison
##' with the assumed truth (as specified by the \code{trueEff} argument to
##' \code{\link{summary,PseudoDualSimulations-method}})}}
##' You can specify any subset of these in the \code{type} argument.
##'
##' @param x the \code{\linkS4class{PseudoDualSimulationsSummary}} object we want to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a `gtable` object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSUMDual.R
##' @export
##' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "PseudoDualSimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLE",
      "nAboveTargetEndOfTrial",
      "meanFit",
      "meanEffFit"
    ),
    ...
  ) {
    ## which plots should be produced?
    type <- match.arg(type, several.ok = TRUE)
    stopifnot(length(type) > 0L)

    ## substract the specific plot types for dual-endpoint
    ## designs
    typeReduced <- setdiff(
      type,
      "meanEffFit"
    )

    ## are there more plots from general?
    moreFromGeneral <- (length(typeReduced) > 0)

    ## if so, then produce these plots
    if (moreFromGeneral) {
      ret <- callNextMethod(x = x, y = y, type = typeReduced)
    }

    ## is the meanBiomarkerFit plot requested?
    if ("meanEffFit" %in% type) {
      ## Find if Effsamples are generated in the simulations
      ## by checking if there the lower limits of the 95% Credibility
      ## interval are calculated
      if (!is.null(x@meanEffFit$lower)) {
        ## which types of lines do we have?
        linetype <- c(
          "True Expected Efficacy",
          "Average estimated expected efficacy",
          "95% interval for estimated expected efficacy"
        )

        ## create the data frame, with
        ## true biomarker, average estimated expected efficacy, and 95% (lower, upper)
        ## estimated biomarker stacked below each other
        dat <- data.frame(
          dose = rep(x@doseGrid, 4L),
          group = rep(1:4, each = length(x@doseGrid)),
          linetype = factor(
            rep(linetype[c(1, 2, 3, 3)], each = length(x@doseGrid)),
            levels = linetype
          ),
          lines = unlist(x@meanEffFit)
        )

        ## linetypes for the plot
        lt <- c(
          "True Expected Efficacy" = 1,
          "Average estimated expected efficacy" = 1,
          "95% interval for estimated expected efficacy" = 2
        )

        ## colour for the plot
        col <- c(
          "True Expected Efficacy" = 1,
          "Average estimated expected efficacy" = 4,
          "95% interval for estimated expected efficacy" = 4
        )

        ## now create and save the plot
        thisPlot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        thisPlot <- thisPlot +
          scale_linetype_manual(values = lt) +
          scale_colour_manual(values = col) +
          xlab("Dose level") +
          ylab("Expected Efficacy level")
      } else {
        linetype <- c(
          "True Expected Efficacy",
          "Average estimated expected efficacy"
        )

        ## create the data frame, with
        ## true biomarker, average estimated expected efficacy
        dat <- data.frame(
          dose = rep(x@doseGrid, 2L),
          group = rep(1:2, each = length(x@doseGrid)),
          linetype = factor(
            rep(linetype[c(1, 2)], each = length(x@doseGrid)),
            levels = linetype
          ),
          lines = unlist(x@meanEffFit)
        )

        ## linetypes for the plot
        lt <- c(
          "True Expected Efficacy" = 1,
          "Average estimated expected efficacy" = 1
        )

        ## colour for the plot
        col <- c(
          "True Expected Efficacy" = 1,
          "Average estimated expected efficacy" = 4
        )

        ## now create and save the plot
        thisPlot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        thisPlot <- thisPlot +
          scale_linetype_manual(values = lt) +
          scale_colour_manual(values = col) +
          xlab("Dose level") +
          ylab("Expected Efficacy level")
      }

      ## add this plot to the bottom
      ret <-
        if (moreFromGeneral) {
          gridExtra::arrangeGrob(ret, thisPlot, heights = c(2 / 3, 1 / 3))
        } else {
          thisPlot
        }
    }

    ## then finally plot everything
    ret
  }
)

# nolint end

#' @include McmcOptions-class.R
#' @include Model-methods.R
#' @include fromQuantiles.R
NULL

# size ----

## Samples ----

#' @describeIn size get the number of MCMC samples from `Samples` object.
#' @aliases size-Samples
#'
#' @export
#' @example examples/Samples-methods-size.R
#'
setMethod(
  f = "size",
  signature = signature(object = "Samples"),
  definition = function(object, ...) {
    size(object@options)
  }
)

# names ----

## Samples ----

#' The Names of the Sampled Parameters
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that returns names of the parameters that are sampled.
#'
#' @param x (`Samples`)\cr object with samples.
#'
#' @aliases names-Samples
#' @export
#' @example examples/Samples-methods-names.R
#'
setMethod(
  f = "names",
  signature = signature(x = "Samples"),
  definition = function(x) {
    names(x@data)
  }
)

## --------------------------------------------------
## Extract certain parameter from "Samples" object to produce
## plots with "ggmcmc" package
## --------------------------------------------------

# The next line is required to suppress the message "Creating a generic function
# for ‘get’ from package ‘base’ in package ‘crmPack’" on package load.
# See https://github.com/openpharma/crmPack/issues/723
setGeneric("get")

#' Get specific parameter samples and produce a data.frame
#'
#' Here you have to specify with \code{pos} which
#' parameter you would like to extract from the \code{\linkS4class{Samples}}
#' object
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param pos the name of the parameter
#' @param envir for vectorial parameters, you can give the indices of the
#' elements you would like to extract. If \code{NULL}, the whole vector samples
#' will be returned
#' @param mode not used
#' @param inherits not used
#'
#' @return the data frame suitable for use with \code{\link[ggmcmc]{ggmcmc}}
#'
#' @example examples/Sample-methods-get.R
#' @export
#' @keywords methods
setMethod(
  "get",
  signature = signature(
    x = "Samples",
    pos = "character",
    envir = "ANY",
    mode = "ANY",
    inherits = "ANY"
  ),
  def = function(x, pos, envir = NULL, mode = NULL, inherits = NULL) {
    ## check the parameter name
    assert_scalar(pos)
    assert_choice(pos, names(x))

    ## get the samples for this parameter
    d <- x@data[[pos]]
    ## this can be either a vector or a matrix

    ## how many parameters do we have?
    nPars <- NCOL(d)

    ## what are the names of all parameter
    ## elements?
    elements <-
      if (nPars == 1L) {
        pos
      } else {
        paste(pos, "[", seq_len(nPars), "]", sep = "")
      }

    ## in case we have a vector parameter
    if (nPars > 1L) {
      ## what are the indices to be returned?
      indices <-
        if (is.null(envir)) {
          seq_along(elements)
        } else {
          assert_integer(envir)
          assert_subset(envir, seq_along(elements))
        }

      ## subset the data matrix and par names appropriately
      d <- d[, indices, drop = FALSE]
      elements <- elements[indices]

      ## and also reduce the number of parameters
      nPars <- length(indices)
    }

    ## now we can build
    ret <- data.frame(
      Iteration = seq_len(NROW(d)),
      Chain = 1L,
      Parameter = factor(rep(elements, each = NROW(d)), levels = elements),
      value = as.numeric(d)
    )

    ## add the attributes
    ret <- structure(
      ret,
      nChains = 1L,
      nParameters = nPars,
      nIterations = x@options@iterations,
      nBurnin = x@options@burnin,
      nThin = x@options@step,
      description = elements,
      parallel = FALSE
    )
    return(ret)
  }
)


## --------------------------------------------------
## Get fitted curves from Samples
## --------------------------------------------------

#' Fit method for the Samples class
#'
#' Note this new generic function is necessary because the \code{\link{fitted}}
#' function only allows the first argument \code{object} to appear in the
#' signature. But we need also other arguments in the signature.
#'
#' @param object the \code{\linkS4class{Samples}} object
#' @param model the \code{\linkS4class{GeneralModel}} object
#' @param data the \code{\linkS4class{Data}} object
#' @param \dots passed down to the [prob()] method.
#' @return the data frame with required information (see method details)
#'
#' @export
#' @keywords methods
setGeneric(
  "fit",
  def = function(object, model, data, ...) {
    ## there should be no default method,
    ## therefore just forward to next method!
    standardGeneric("fit")
  },
  valueClass = "data.frame"
)


## --------------------------------------------------
## Get fitted dose-tox curve from Samples
## --------------------------------------------------

#' @param points at which dose levels is the fit requested? default is the dose
#' grid
#' @param quantiles the quantiles to be calculated (default: 0.025 and
#' 0.975)
#' @param middle the function for computing the middle point. Default:
#' \code{\link{mean}}
#'
#' @describeIn fit This method returns a data frame with dose, middle, lower
#' and upper quantiles for the dose-toxicity curve
#' @example examples/Sample-methods-fit.R
#'
setMethod(
  "fit",
  signature = signature(
    object = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  def = function(
    object,
    model,
    data,
    points = data@doseGrid,
    quantiles = c(0.025, 0.975),
    middle = mean,
    ...
  ) {
    ## some checks
    assert_probability_range(quantiles)
    assert_numeric(points)

    ## first we have to get samples from the dose-tox
    ## curve at the dose grid points.
    probSamples <- matrix(
      nrow = size(object),
      ncol = length(points)
    )

    ## evaluate the probs, for all samples.
    for (i in seq_along(points)) {
      ## Now we want to evaluate for the
      ## following dose:
      probSamples[, i] <- prob(
        dose = points[i],
        model,
        object,
        ...
      )
    }

    ## extract middle curve
    middleCurve <- apply(probSamples, 2L, FUN = middle)

    ## extract quantiles
    quantCurve <- apply(probSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    ret <- data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )

    ## return it
    return(ret)
  }
)

## --------------------------------------------------
## Get fitted dose-tox and dose-biomarker curves from Samples
## --------------------------------------------------

#' @describeIn fit This method returns a data frame with dose, and middle,
#' lower and upper quantiles, for both the dose-tox and dose-biomarker (suffix
#' "Biomarker") curves, for all grid points (Note that currently only the grid
#' points can be used, because the DualEndpointRW models only allow that)
#'
#' @example examples/Sample-methods-fit-DualEndpoint.R
setMethod(
  "fit",
  signature = signature(
    object = "Samples",
    model = "DualEndpoint",
    data = "DataDual"
  ),
  def = function(
    object,
    model,
    data,
    quantiles = c(0.025, 0.975),
    middle = mean,
    ...
  ) {
    ## some checks
    assert_probability_range(quantiles)

    ## first obtain the dose-tox curve results from the parent method
    start <- callNextMethod(
      object = object,
      model = model,
      data = data,
      points = data@doseGrid,
      quantiles = quantiles,
      middle = middle,
      ...
    )

    ## now obtain the dose-biomarker results

    ## get the biomarker level samples
    ## at the dose grid points.
    biomLevelSamples <- biomarker(
      xLevel = seq_len(data@nGrid),
      model,
      samples = object
    )

    ## extract middle curve
    middleCurve <- apply(biomLevelSamples, 2L, FUN = middle)

    ## extract quantiles
    quantCurve <- apply(biomLevelSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    biomResults <- data.frame(
      middleBiomarker = middleCurve,
      lowerBiomarker = quantCurve[1, ],
      upperBiomarker = quantCurve[2, ]
    )

    ## return both, pasted together
    return(cbind(start, biomResults))
  }
)

## --------------------------------------------------
## Approximate posterior with (log) normal distribution
## --------------------------------------------------

#' Approximate posterior with (log) normal distribution
#'
#' To reproduce the resultant approximate model in the future exactly, include
#' \code{seed = xxxx} in the call to `approximate`.
#'
#' @param object the \code{\linkS4class{Samples}} object
#' @param model the \code{\linkS4class{GeneralModel}} object
#' @param data the \code{\linkS4class{Data}} object
#' @param \dots additional arguments (see methods)
#' @return a `list` containing the approximation model and, if requested, a
#' `ggplot2` object containing a graphical representation of the fitted model
#'
#' @export
#' @keywords methods
setGeneric(
  "approximate",
  def = function(object, model, data, ...) {
    ## there should be no default method,
    ## therefore just forward to next method!
    standardGeneric("approximate")
  },
  valueClass = "list"
)


##' @param points optional parameter, which gives the dose values at which
##' the approximation should rely on (default: 5 values equally spaced from
##' minimum to maximum of the dose grid)
##' @param refDose the reference dose to be used (default: median of
##' \code{points})
##' @param logNormal use the log-normal prior? (not default) otherwise, the
##' normal prior for the logistic regression coefficients is used
##' @param verbose be verbose (progress statements)? (default)
##' @param create_plot add a `ggplot2` object to the return value (default)
##'
##' @describeIn approximate Here the \dots argument can transport additional arguments for
##' \code{\link{Quantiles2LogisticNormal}}, e.g. in order to control the
##' approximation quality, etc.
##'
##' @example examples/Sample-methods-approximate.R
setMethod(
  "approximate",
  signature = signature(object = "Samples"),
  def = function(
    object,
    model,
    data,
    points = seq(
      from = min(data@doseGrid),
      to = max(data@doseGrid),
      length = 5L
    ),
    refDose = median(points),
    logNormal = FALSE,
    verbose = TRUE,
    create_plot = TRUE,
    ...
  ) {
    # Validation
    assert_logical(logNormal)
    assert_logical(verbose)
    assert_logical(create_plot)
    assert_numeric(points)
    assert_numeric(refDose)
    ## get the required quantiles at these dose levels:
    quants <- fit(
      object,
      model,
      data,
      points = points,
      quantiles = c(0.025, 0.975),
      middle = median
    )

    ## get better starting values if it is already a logistic normal
    ## model
    if (is(model, "LogisticNormal") && (!logNormal)) {
      means <- sapply(
        object@data,
        mean
      )
      cov <- cov(as.data.frame(object@data))

      parstart <- c(
        means[1],
        means[2],
        sqrt(cov[1, 1]),
        sqrt(cov[2, 2]),
        cov2cor(cov)[1, 2]
      )
    } else if (is(model, "LogisticLogNormal") && logNormal) {
      datTrafo <- with(
        object@data,
        cbind(
          alpha0,
          log(alpha1)
        )
      )

      means <- colMeans(datTrafo)
      cov <- cov(datTrafo)

      parstart <- c(
        means[1],
        means[2],
        sqrt(cov[1, 1]),
        sqrt(cov[2, 2]),
        cov2cor(cov)[1, 2]
      )
    } else {
      parstart <- NULL
    }

    ## run the approx function
    quantRes <- Quantiles2LogisticNormal(
      dosegrid = quants$dose,
      refDose = refDose,
      lower = quants$lower,
      upper = quants$upper,
      median = quants$middle,
      verbose = verbose,
      parstart = parstart,
      logNormal = logNormal,
      ...
    )
    rv <- list()
    rv$model <- quantRes$model
    if (create_plot) {
      rv$plot <- tibble::as_tibble(quantRes$required) %>%
        tibble::add_column(Type = "original") %>%
        tibble::add_column(x = points) %>%
        dplyr::bind_rows(
          tibble::as_tibble(quantRes$quantiles) %>%
            tibble::add_column(Type = "approximation") %>%
            tibble::add_column(x = points)
        ) %>%
        tidyr::pivot_longer(
          c(lower, median, upper),
          names_to = "Line",
          values_to = "y"
        ) %>%
        ggplot(
          aes(
            x = x,
            y = y,
            colour = Type,
            group = interaction(Type, .data$Line),
            linetype = (.data$Line == "median")
          )
        ) +
        geom_line() +
        scale_colour_manual(
          name = " ",
          values = c("red", "blue")
        ) +
        scale_linetype_manual(
          name = " ",
          values = c("dotted", "solid"),
          labels = c("95% CI", "Median"),
          guide = guide_legend(reverse = TRUE)
        ) +
        labs(
          x = "Dose",
          y = "p(Tox)"
        ) +
        theme_light()
    }

    ## return the results
    return(rv)
  }
)

## --------------------------------------------------
## Plot dose-tox fit from a model
## --------------------------------------------------

#' Plotting dose-toxicity model fits
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{GeneralModel}} object
#' @param data the \code{\linkS4class{Data}} object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-toxicity model fit
#'
#' @example examples/Sample-methods-plot.R
#' @export
setMethod(
  "plot",
  signature = signature(
    x = "Samples",
    y = "GeneralModel"
  ),
  def = function(
    x,
    y,
    data,
    ...,
    xlab = "Dose level",
    ylab = "Probability of DLT [%]",
    showLegend = TRUE
  ) {
    ## check args
    assert_logical(showLegend)

    ## get the fit
    plotData <- fit(
      x,
      model = y,
      data = data,
      quantiles = c(0.025, 0.975),
      middle = mean,
      ...
    )

    ## make the plot
    gdata <-
      with(
        plotData,
        data.frame(
          x = rep(dose, 3),
          y = c(middle, lower, upper) * 100,
          group = rep(c("mean", "lower", "upper"), each = nrow(plotData)),
          Type = factor(
            c(
              rep(
                "Estimate",
                nrow(plotData)
              ),
              rep(
                "95% Credible Interval",
                nrow(plotData) * 2
              )
            ),
            levels = c(
              "Estimate",
              "95% Credible Interval"
            )
          )
        )
      )

    ret <- gdata %>%
      ggplot() +
      geom_line(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type,
        ),
        colour = I("red"),
      ) +
      coord_cartesian(ylim = c(0, 100)) +
      labs(
        x = xlab,
        y = ylab,
      )

    ret <- ret +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )

    return(ret)
  }
)


## --------------------------------------------------
## Special method for dual endpoint model
## --------------------------------------------------

#' Plotting dose-toxicity and dose-biomarker model fits
#'
#' When we have the dual endpoint model,
#' also the dose-biomarker fit is shown in the plot
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{DualEndpoint}} object
#' @param data the \code{\linkS4class{DataDual}} object
#' @param extrapolate should the biomarker fit be extrapolated to the whole
#' dose grid? (default)
#' @param showLegend should the legend be shown? (not default)
#' @param \dots additional arguments for the parent method
#' \code{\link{plot,Samples,GeneralModel-method}}
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object with the dose-toxicity and dose-biomarker model fits
#'
#' @example examples/Sample-methods-plot-DualEndpoint.R
#' @export
setMethod(
  "plot",
  signature = signature(
    x = "Samples",
    y = "DualEndpoint"
  ),
  def = function(x, y, data, extrapolate = TRUE, showLegend = FALSE, ...) {
    assert_logical(extrapolate)

    ## call the superclass method, to get the toxicity plot
    plot1 <- callNextMethod(x, y, data, showLegend = showLegend, ...)

    ## only look at these dose levels for the plot:
    xLevels <-
      if (extrapolate) {
        seq_along(data@doseGrid)
      } else {
        1:max(data@xLevel)
      }

    ## get the plot data for the biomarker plot
    functionSamples <- biomarker(xLevel = xLevels, model = y, samples = x)

    ## extract mean curve
    meanCurve <- colMeans(functionSamples)

    ## extract quantiles
    quantiles <- c(0.025, 0.975)
    quantCurve <- apply(functionSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    plotData <- data.frame(
      dose = data@doseGrid[xLevels],
      mean = meanCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )

    ## make the second plot
    gdata <-
      with(
        plotData,
        data.frame(
          x = rep(dose, 3),
          y = c(mean, lower, upper),
          group = rep(c("mean", "lower", "upper"), each = nrow(plotData)),
          Type = factor(
            c(
              rep(
                "Estimate",
                nrow(plotData)
              ),
              rep(
                "95% Credible Interval",
                nrow(plotData) * 2
              )
            ),
            levels = c(
              "Estimate",
              "95% Credible Interval"
            )
          )
        )
      )
    plot2 <- gdata %>%
      ggplot() +
      geom_line(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type
        ),
        colour = I("blue")
      ) +
      labs(
        x = "Dose level",
        y = "Biomarker level"
      )

    plot2 <- plot2 +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )

    ## arrange both plots side by side
    ret <- gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
    return(ret)
  }
)


## -------------------------------------------------------------------------------------
## Get fitted dose-tox curve from Samples for 'LogisticIndepBeta' model class
## ------------------------------------------------------------------------------------
#' @describeIn fit This method return a data frame with dose, middle lower and upper quantiles
#' for the dose-DLE curve using DLE samples for \dQuote{LogisticIndepBeta} model class
#' @example examples/Samples-method-fitDLE.R
setMethod(
  "fit",
  signature = signature(
    object = "Samples",
    model = "LogisticIndepBeta",
    data = "Data"
  ),
  def = function(
    object,
    model,
    data,
    points = data@doseGrid,
    quantiles = c(0.025, 0.975),
    middle = mean,
    ...
  ) {
    ## some checks
    assert_probability_range(quantiles)
    assert_numeric(points)

    ## first we have to get samples from the dose-tox
    ## curve at the dose grid points.
    probSamples <- matrix(
      nrow = size(object),
      ncol = length(points)
    )

    ## evaluate the probs, for all samples.
    for (i in seq_along(points)) {
      ## Now we want to evaluate for the
      ## following dose:
      probSamples[, i] <- prob(
        dose = points[i],
        model,
        object
      )
    }

    ## extract middle curve
    middleCurve <- apply(probSamples, 2L, FUN = middle)

    ## extract quantiles
    quantCurve <- apply(probSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    ret <- data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )

    ## return it
    return(ret)
  }
)

## -------------------------------------------------------------------------------------
## Get fitted dose-efficacy curve from Samples for 'Effloglog' model class
## ------------------------------------------------------------------------------------

#' @describeIn fit This method returns a data frame with dose, middle, lower, upper quantiles for
#' the dose-efficacy curve using efficacy samples for \dQuote{Effloglog} model class
#' @example examples/Samples-method-fitEff.R
setMethod(
  "fit",
  signature = signature(
    object = "Samples",
    model = "Effloglog",
    data = "DataDual"
  ),
  def = function(
    object,
    model,
    data,
    points = data@doseGrid,
    quantiles = c(0.025, 0.975),
    middle = mean,
    ...
  ) {
    ## some checks
    assert_probability_range(quantiles)
    assert_numeric(points)

    ## first we have to get samples from the dose-tox
    ## curve at the dose grid points.
    ExpEffSamples <- matrix(
      nrow = size(object),
      ncol = length(points)
    )

    ## evaluate the probs, for all samples.
    for (i in seq_along(points)) {
      ## Now we want to evaluate for the
      ## following dose:
      ExpEffSamples[, i] <- efficacy(
        dose = points[i],
        model,
        object
      )
    }

    ## extract middle curve
    middleCurve <- apply(ExpEffSamples, 2L, FUN = middle)

    ## extract quantiles
    quantCurve <- apply(ExpEffSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    ret <- data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )

    ## return it
    return(ret)
  }
)
## ==========================================================================================
## --------------------------------------------------------------------
## Get fitted dose-efficacy based on the Efficacy Flexible model
## -------------------------------------------------------------
#' @describeIn fit This method returns a data frame with dose, middle, lower and upper
#' quantiles for the dose-efficacy curve using efficacy samples for \dQuote{EffFlexi}
#' model class
#' @example examples/Samples-method-fitEffFlexi.R
setMethod(
  "fit",
  signature = signature(
    object = "Samples",
    model = "EffFlexi",
    data = "DataDual"
  ),
  def = function(
    object,
    model,
    data,
    points = data@doseGrid,
    quantiles = c(0.025, 0.975),
    middle = mean,
    ...
  ) {
    ## some checks
    assert_probability_range(quantiles)
    assert_numeric(points)

    ## first we have to get samples from the dose-tox
    ## curve at the dose grid points.
    ExpEffSamples <- matrix(
      nrow = size(object),
      ncol = length(points)
    )

    ## evaluate the probs, for all samples.
    for (i in seq_along(points)) {
      ## Now we want to evaluate for the
      ## following dose:
      ExpEffSamples[, i] <- efficacy(
        dose = points[i],
        model,
        object
      )
    }

    ## extract middle curve
    middleCurve <- apply(ExpEffSamples, 2L, FUN = middle)

    ## extract quantiles
    quantCurve <- apply(ExpEffSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    ret <- data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )

    ## return it
    return(ret)
  }
)

#' @describeIn fit This method returns a data frame with dose, middle, lower
#' and upper quantiles for the dose-efficacy curve using efficacy samples
#' for the \dQuote{LogisticLogNormalOrdinal} model class
#' @example examples/Sample-methods-fit-LogisticLogNormalOrdinal.R
setMethod(
  "fit",
  signature = signature(
    object = "Samples",
    model = "LogisticLogNormalOrdinal",
    data = "DataOrdinal"
  ),
  def = function(
    object,
    model,
    data,
    points = data@doseGrid,
    quantiles = c(0.025, 0.975),
    middle = mean,
    ...
  ) {
    # Validation
    assert_probability_range(quantiles)
    assert_numeric(points)
    assert_function(middle)

    # Begin
    # Get samples from the dose-tox curve at the dose grid points.
    probSamples <- matrix(
      nrow = size(object),
      ncol = length(points)
    )
    # Evaluate the probs, for all samples.
    for (i in seq_along(points)) {
      # Now we want to evaluate for the following dose:
      probSamples[, i] <- prob(
        dose = points[i],
        model,
        object,
        ...
      )
    }
    # Extract middle curve
    middleCurve <- apply(probSamples, 2L, FUN = middle)
    # Extract quantiles
    quantCurve <- apply(probSamples, 2L, quantile, prob = quantiles)

    # Create the data frame...
    ret <- data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )

    # ...and return it
    return(ret)
  }
)
## ==============================================================
## ----------------------------------------------------------------
## Get fitted values at all dose levels from gain samples
## -----------------------------------------------------------------
#' Get the fitted values for the gain values at all dose levels based on
#' a given pseudo DLE model, DLE sample, a pseudo efficacy model, a Efficacy sample
#' and data. This method returns a data frame with dose, middle, lower and upper quantiles
#' of the gain value samples
#'
#' @param DLEmodel the DLE pseudo model of \code{\linkS4class{ModelTox}} class object
#' @param DLEsamples the DLE samples of \code{\linkS4class{Samples}} class object
#' @param Effmodel the efficacy pseudo model of \code{\linkS4class{ModelEff}} class object
#' @param Effsamples the efficacy samples of \code{\linkS4class{Samples}} class object
#' @param data the data input of \code{\linkS4class{DataDual}} class object
#' @param \dots additional arguments for methods
#'
#' @export
#' @keywords methods
#' @example examples/Samples-method-fitGain.R
setGeneric(
  "fitGain",
  def = function(DLEmodel, DLEsamples, Effmodel, Effsamples, data, ...) {
    ## there should be no default method,
    ## therefore just forward to next method!
    standardGeneric("fitGain")
  },
  valueClass = "data.frame"
)

#' @describeIn fitGain This method returns a data frame with dose, middle, lower, upper quantiles for
#' the gain values obtained given the DLE and the efficacy samples
#' @param points at which dose levels is the fit requested? default is the dose
#' grid
#' @param quantiles the quantiles to be calculated (default: 0.025 and
#' 0.975)
#' @param middle the function for computing the middle point. Default:
#' \code{\link{mean}}
#' @example examples/Samples-method-fitGain.R
setMethod(
  "fitGain",
  signature = signature(
    DLEmodel = "ModelTox",
    DLEsamples = "Samples",
    Effmodel = "ModelEff",
    Effsamples = "Samples",
    data = "DataDual"
  ),
  def = function(
    DLEmodel,
    DLEsamples,
    Effmodel,
    Effsamples,
    data,
    points = data@doseGrid,
    quantiles = c(0.025, 0.975),
    middle = mean,
    ...
  ) {
    ## some checks
    assert_probability_range(quantiles)
    assert_numeric(points)

    ## first we have to get samples from the gain
    ## at the dose grid points.
    GainSamples <- matrix(
      nrow = size(DLEsamples),
      ncol = length(points)
    )

    ## evaluate the probs, for all gain samples.
    for (i in seq_along(points)) {
      ## Now we want to evaluate for the
      ## following dose:
      GainSamples[, i] <- gain(
        dose = points[i],
        DLEmodel,
        DLEsamples,
        Effmodel,
        Effsamples
      )
    }

    ## extract middle curve
    middleCurve <- apply(GainSamples, 2L, FUN = middle)

    ## extract quantiles
    quantCurve <- apply(GainSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    ret <- data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )

    ## return it
    return(ret)
  }
)
## ---------------------------------------------------------------------------------
## Plot the fitted dose-DLE curve with pseudo DLE model with samples
## -------------------------------------------------------------------------------
#' Plot the fitted dose-DLE curve using a \code{\linkS4class{ModelTox}} class model with samples
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{ModelTox}} model class object
#' @param data the \code{\linkS4class{Data}} object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-DLE model fit
#'
#' @example examples/Samples-method-plotModelTox.R
#' @export
#' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "Samples",
    y = "ModelTox"
  ),
  def = function(
    x,
    y,
    data,
    ...,
    xlab = "Dose level",
    ylab = "Probability of DLT [%]",
    showLegend = TRUE
  ) {
    ## check args
    assert_logical(showLegend)

    ## get the fit
    plotData <- fit(
      x,
      model = y,
      data = data,
      quantiles = c(0.025, 0.975),
      middle = mean
    )

    ## make the plot
    gdata <-
      with(
        plotData,
        data.frame(
          x = rep(dose, 3),
          y = c(middle, lower, upper) * 100,
          group = rep(c("mean", "lower", "upper"), each = nrow(plotData)),
          Type = factor(
            c(
              rep(
                "Estimate",
                nrow(plotData)
              ),
              rep(
                "95% Credible Interval",
                nrow(plotData) * 2
              )
            ),
            levels = c(
              "Estimate",
              "95% Credible Interval"
            )
          )
        )
      )

    ret <- gdata %>%
      ggplot() +
      geom_line(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type
        ),
        colour = I("red"),
      ) +
      coord_cartesian(ylim = c(0, 100)) +
      labs(
        x = xlab,
        y = ylab
      )

    ret <- ret +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )

    return(ret)
  }
)


# --------------------------------------------------------------------------------------------
## Plot the fitted dose-efficacy curve using a pseudo efficacy model with samples
## -------------------------------------------------------------------------------------------
#' Plot the fitted dose-efficacy curve using a model from \code{\linkS4class{ModelEff}} class
#' with samples
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{ModelEff}} model class object
#' @param data the \code{\linkS4class{Data}} object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-efficacy model fit
#'
#' @example examples/Samples-method-plotModelEff.R
#' @export
#' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "Samples",
    y = "ModelEff"
  ),
  def = function(
    x,
    y,
    data,
    ...,
    xlab = "Dose level",
    ylab = "Expected Efficacy",
    showLegend = TRUE
  ) {
    ## check args
    assert_logical(showLegend)

    ## get the fit
    plotData <- fit(
      x,
      model = y,
      data = data,
      quantiles = c(0.025, 0.975),
      middle = mean
    )

    ## make the plot
    gdata <-
      with(
        plotData,
        data.frame(
          x = rep(dose, 3),
          y = c(middle, lower, upper),
          group = rep(c("mean", "lower", "upper"), each = nrow(plotData)),
          Type = factor(
            c(
              rep(
                "Estimate",
                nrow(plotData)
              ),
              rep(
                "95% Credible Interval",
                nrow(plotData) * 2
              )
            ),
            levels = c(
              "Estimate",
              "95% Credible Interval"
            )
          )
        )
      )

    ret <- gdata %>%
      ggplot() +
      geom_line(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type
        ),
        colour = I("blue")
      ) +
      labs(
        x = xlab,
        y = ylab
      ) +
      coord_cartesian(xlim = c(0, max(data@doseGrid)))

    ret <- ret +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )

    return(ret)
  }
)

## ----------------------------------------------------------------------------------------
## Plot of fitted dose-DLE curve based on a pseudo DLE model without sample
## -------------------------------------------------------------------------------------
#' Plot of the fitted dose-tox based with a given pseudo DLE model and data without samples
#'
#' @param x the data of \code{\linkS4class{Data}} class object
#' @param y the model of the \code{\linkS4class{ModelTox}} class object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-DLE model plot
#'
#' @example examples/Samples-method-plotModelToxNoSamples.R
#' @export
#' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "Data",
    y = "ModelTox"
  ),
  def = function(
    x,
    y,
    xlab = "Dose level",
    ylab = "Probability of DLE",
    showLegend = TRUE,
    ...
  ) {
    ## check args
    assert_logical(showLegend)

    ## Make sure the right model estimates are use with the given data
    y <- update(object = y, data = x)

    ## create data frame

    plotData <- data.frame(
      dose = x@doseGrid,
      probDLE = prob(
        dose = x@doseGrid,
        model = y
      )
    )
    ## Look for TD30 and TD35
    TD30 <- dose(
      x = 0.30,
      model = y
    )
    TD35 <- dose(
      x = 0.35,
      model = y
    )

    ## make the plot
    gdata <- with(
      plotData,
      data.frame(
        x = dose,
        y = probDLE,
        group = rep("Estimated DLE", each = nrow(plotData)),
        Type = factor(
          rep("Estimated DLE", nrow(plotData)),
          levels = "Estimated DLE"
        )
      )
    )

    plot1 <- gdata %>%
      ggplot() +
      geom_line(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type
        ),
        colour = I("red"),
        linewidth = 1.5
      ) +
      labs(
        x = xlab,
        y = ylab
      ) +
      coord_cartesian(ylim = c(0, 1)) +
      scale_linetype_manual(
        breaks = "Estimated DLE",
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )
    return(plot1)
  }
)


## ---------------------------------------------------------------------------------------------
## Plot the fitted dose-efficacy curve given a pseudo efficacy model without samples
## ----------------------------------------------------------------------------------
#' Plot of the fitted dose-efficacy based with a given pseudo efficacy model and data without samples
#'
#' @param x the data of \code{\linkS4class{DataDual}} class object
#' @param y the model of the \code{\linkS4class{ModelEff}} class object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-efficacy model plot
#'
#' @example examples/Samples-method-plotModelEffNoSamples.R
#' @export
#' @keywords methods
setMethod(
  "plot",
  signature = signature(
    x = "DataDual",
    y = "ModelEff"
  ),
  def = function(
    x,
    y,
    ...,
    xlab = "Dose level",
    ylab = "Expected Efficacy",
    showLegend = TRUE
  ) {
    ## check args
    assert_logical(showLegend)
    y <- update(object = y, data = x)

    ## create data frame

    plotEffData <- data.frame(
      dose = x@doseGrid,
      ExpEff = efficacy(
        dose = x@doseGrid,
        model = y
      )
    )

    ## make the second plot
    ggdata <- with(
      plotEffData,
      data.frame(
        x = dose,
        y = ExpEff,
        group = rep("Estimated Expected Efficacy", each = nrow(plotEffData)),
        Type = factor(
          rep("Estimated Expected Efficacy", nrow(plotEffData)),
          levels = "Estimated Expected Efficacy"
        )
      )
    )

    ## Get efficacy plot
    plot2 <- ggplot(data = ggdata, aes(x = x, y = y), group = group) +
      xlab("Dose Levels") +
      ylab(paste("Estimated Expected Efficacy")) +
      xlim(c(0, max(x@doseGrid))) +
      geom_line(colour = I("blue"), linewidth = 1.5)

    plot2 <- plot2 +
      geom_line(linewidth = 1.5, colour = "blue")

    return(plot2)
  }
)

## ----------------------------------------------------------------------------------------------------------
## Plot the gain curve using a pseudo DLE and a pseudo Efficacy model with samples
## ----------------------------------------------------------------------------------------------------
#' Plot the gain curve in addition with the dose-DLE and dose-efficacy curve using a given DLE pseudo model,
#' a DLE sample, a given efficacy pseudo model and an efficacy sample
#'
#' @param DLEmodel the dose-DLE model of \code{\linkS4class{ModelTox}} class object
#' @param DLEsamples the DLE sample of \code{\linkS4class{Samples}} class object
#' @param Effmodel the dose-efficacy model of \code{\linkS4class{ModelEff}} class object
#' @param Effsamples the efficacy sample of of \code{\linkS4class{Samples}} class object
#' @param data the data input of \code{\linkS4class{DataDual}} class object
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the plot
#'
#' @example examples/Samples-method-plotGain.R
#' @export
#' @keywords methods
setGeneric(
  "plotGain",
  def = function(DLEmodel, DLEsamples, Effmodel, Effsamples, data, ...) {
    standardGeneric("plotGain")
  }
)
#' @describeIn plotGain Standard method
setMethod(
  "plotGain",
  signature = signature(
    DLEmodel = "ModelTox",
    DLEsamples = "Samples",
    Effmodel = "ModelEff",
    Effsamples = "Samples"
  ),
  def = function(DLEmodel, DLEsamples, Effmodel, Effsamples, data, ...) {
    ## Get fitted values for probabilities of DLE at all dose levels

    plotDLEData <- fit(
      DLEsamples,
      model = DLEmodel,
      data = data,
      quantiles = c(0.025, 0.975),
      middle = mean
    )

    ## Get fitted values for mean efficacy values at all dose levels
    plotEffData <- fit(
      Effsamples,
      model = Effmodel,
      data = data,
      quantiles = c(0.025, 0.975),
      middle = mean
    )

    ## Get fitted values for gain values at all dose levels
    plotGainData <- fitGain(
      DLEmodel = DLEmodel,
      DLEsamples = DLEsamples,
      Effmodel = Effmodel,
      Effsamples = Effsamples,
      data = data
    )

    ## For each of the dose levels, take the mean for the probabilties of DLE, mean efiicacy values
    ## and gain values. Hence combine them into a data frame

    plotData <- data.frame(
      dose = rep(data@doseGrid, 3),
      values = c(
        plotDLEData$middle,
        plotEffData$middle,
        plotGainData$middle
      )
    )
    ## only the line plots for the mean value of the DLE, efficacy and gain samples
    ## at all dose levels
    gdata <- with(
      plotData,
      data.frame(
        x = dose,
        y = values,
        group = c(
          rep("p(DLE)", length(data@doseGrid)),
          rep("Mean Expected Efficacy", length(data@doseGrid)),
          rep("Gain", length(data@doseGrid))
        ),
        Type = factor("Estimate", levels = "Estimate")
      )
    )

    plot1 <- ggplot(data = gdata, aes(x = x, y = y)) +
      geom_line(aes(group = group, color = group), linewidth = 1.5) +
      scale_colour_manual(
        name = "curves",
        values = c("green3", "blue", "red")
      ) +
      xlab("Dose Level") +
      xlim(c(0, max(data@doseGrid))) +
      ylab(paste("Values")) +
      ylim(c(min(gdata$y), max(gdata$y)))
    return(plot1)
  }
)

## ----------------------------------------------------------------------------------------------------
## Plot the gain curve using a pseudo DLE and a pseudo Efficacy model without samples
## ----------------------------------------------------------------------------------------------------
#' Plot the gain curve in addition with the dose-DLE and dose-efficacy curve using a given DLE pseudo model,
#' and a given efficacy pseudo model
#'
#' @describeIn plotGain Standard method
#' @param size (`integer`)\cr a vector of length two defining the sizes of
#' the shapes used to identify the doses with, respectively, p(DLE = 0.3) and the
#' maximum gain
#' @param shape (`integer`)\cr a vector of length two defining the shapes
#' used to identify the doses with, respectively, p(DLE = 0.3) and the maximum gain
#'
#' @example examples/Samples-method-plotGainNoSamples.R
#' @export
#' @keywords methods
setMethod(
  "plotGain",
  signature = signature(
    DLEmodel = "ModelTox",
    DLEsamples = "missing",
    Effmodel = "ModelEff",
    Effsamples = "missing"
  ),
  def = function(
    DLEmodel,
    Effmodel,
    data,
    size = c(8L, 8L),
    shape = c(16L, 17L),
    ...
  ) {
    assert_integer(size, len = 2, any.missing = FALSE, lower = 0, upper = 20)
    assert_integer(
      shape,
      len = 2,
      any.missing = FALSE,
      unique = TRUE,
      lower = 0,
      upper = 25
    )
    ## Make sure the model estimates are corresponds to the input data
    DLEmodel <- update(object = DLEmodel, data = data)
    Effmodel <- update(object = Effmodel, data = data)

    plotData <- data.frame(
      dose = rep(data@doseGrid, 3),
      values = c(
        prob(
          dose = data@doseGrid,
          model = DLEmodel
        ),
        efficacy(
          dose = data@doseGrid,
          model = Effmodel
        ),
        gain(
          dose = data@doseGrid,
          model_dle = DLEmodel,
          model_eff = Effmodel
        )
      )
    )
    gdata <- with(
      plotData,
      data.frame(
        x = dose,
        y = values,
        group = c(
          rep("p(DLE)", length(data@doseGrid)),
          rep("Expected Efficacy", length(data@doseGrid)),
          rep("Gain", length(data@doseGrid))
        ),
        colour = rep(c("blue", "green3", "red")),
        Type = factor("Estimate", levels = "Estimate")
      )
    )

    # if changing the line type is unacceptable, consider
    # https://stackoverflow.com/questions/25632242/filled-and-hollow-shapes-where-the-fill-color-the-line-color
    plot1 <- ggplot(data = gdata, aes(x = x, y = y)) +
      geom_line(
        aes(group = group, linetype = group, colour = group),
        linewidth = 1
      ) +
      scale_colour_manual(
        name = "Curves",
        values = c("blue", "green3", "red")
      ) +
      scale_linetype_manual(
        name = "Curves",
        values = c("solid", "dotted", "dashed")
      ) +
      xlab("Dose Level") +
      ylab(paste("Values"))

    TD30 <- dose(x = 0.3, model = DLEmodel)

    Gainfun <- function(DOSE) {
      -gain(DOSE, model_dle = DLEmodel, model_eff = Effmodel)
    }
    Gstar <- (optim(
      min(data@doseGrid),
      Gainfun,
      method = "L-BFGS-B",
      lower = min(data@doseGrid),
      upper = max(data@doseGrid)
    )$par)
    MaxGain <- -(optim(
      min(data@doseGrid),
      Gainfun,
      method = "L-BFGS-B",
      lower = min(data@doseGrid),
      upper = max(data@doseGrid)
    )$value)

    if ((TD30 < min(data@doseGrid)) | (TD30 > max(data@doseGrid))) {
      plot1 <- plot1
      message(paste("TD30", paste(TD30, " not within dose Grid")))
    } else {
      plot1 <- plot1 +
        geom_point(
          data = data.frame(x = TD30, y = 0.3),
          aes(x = x, y = y),
          colour = "violet",
          shape = 16,
          size = 8
        ) +
        annotate(
          "text",
          label = "p(DLE=0.3)",
          x = TD30 + 1,
          y = 0.2,
          size = 5,
          colour = "violet"
        )
    }

    # Add annotated point estimates to graph
    point_data <- tibble::tibble(
      Text = NA_character_,
      X = NA_real_,
      Y = NA_real_,
      Shape = NA_real_,
      Size = NA_real_,
      Colour = NA_character_,
      .rows = 0
    )

    if ((TD30 < min(data@doseGrid)) | (TD30 > max(data@doseGrid))) {
      message(paste("TD30", paste(TD30, " not within dose Grid")))
    } else {
      point_data <- point_data %>%
        tibble::add_row(
          X = TD30,
          Y = 0.3,
          Shape = shape[1],
          Size = size[1],
          Colour = "violet",
          Text = "p(DLE=0.3)"
        )
    }
    if ((Gstar < min(data@doseGrid)) | (Gstar > max(data@doseGrid))) {
      print(paste("Gstar=", paste(Gstar, " not within dose Grid")))
    } else {
      plot1 <- plot1 +
        geom_point(
          data = data.frame(x = Gstar, y = MaxGain),
          aes(x = x, y = y),
          colour = "green3",
          shape = 17,
          size = 8
        ) +
        annotate(
          "text",
          label = "Max Gain",
          x = Gstar,
          y = MaxGain - 0.1,
          size = 5,
          colour = "green3"
        )
    }
    point_data <- point_data %>%
      tibble::add_row(
        X = Gstar,
        Y = MaxGain,
        Shape = shape[2],
        Size = size[2],
        Colour = "green3",
        Text = "Max Gain"
      )

    plot1 <- plot1 +
      geom_point(
        data = point_data,
        inherit.aes = FALSE,
        aes(
          x = .data$X,
          y = .data$Y,
          shape = as.factor(.data$Shape),
          fill = .data$Colour
        ),
        colour = point_data$Colour,
        size = point_data$Size,
      ) +
      scale_fill_manual(
        name = "Estimates",
        labels = c("p(DLE = 0.3)", "Max Gain"),
        values = point_data$Colour
      ) +
      scale_shape_discrete(
        name = "Estimates",
        labels = c("p(DLE = 0.3)", "Max Gain"),
        breaks = point_data$Shape
      ) +
      guides(
        shape = guide_legend(override.aes = list(color = c("violet", "green3")))
      ) +
      coord_cartesian(
        xlim = c(0, max(data@doseGrid)),
        ylim = c(min(gdata$y), max(gdata$y))
      )
    return(plot1)
  }
)
## ==========================================================================================

## -------------------------------------------------------------------------------
## Plot of the DLE and efficacy curve sides by side with samples
## -----------------------------------------------------------------------------
#' Plot of the DLE and efficacy curve side by side given a DLE pseudo model,
#' a DLE sample, an efficacy pseudo model and a given efficacy sample
#'
#' @param DLEmodel the pseudo DLE model of \code{\linkS4class{ModelTox}} class object
#' @param DLEsamples the DLE samples of \code{\linkS4class{Samples}} class object
#' @param Effmodel the pseudo efficacy model of \code{\linkS4class{ModelEff}} class object
#' @param Effsamples the Efficacy samples of \code{\linkS4class{Samples}} class object
#' @param data the data input of \code{\linkS4class{DataDual}} class object
#' @param extrapolate should the biomarker fit be extrapolated to the whole
#' dose grid? (default)
#' @param showLegend should the legend be shown? (not default)
#' @param \dots additional arguments for the parent method
#' \code{\link{plot,Samples,GeneralModel-method}}
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object with the dose-toxicity and dose-efficacy model fits
#'
#' @example examples/Samples-method-plotDualResponses.R
#'
#' @export
#' @keywords methods
setGeneric(
  "plotDualResponses",
  def = function(DLEmodel, DLEsamples, Effmodel, Effsamples, data, ...) {
    standardGeneric("plotDualResponses")
  }
)

#' @describeIn plotDualResponses function still to be documented
setMethod(
  "plotDualResponses",
  signature = signature(
    DLEmodel = "ModelTox",
    DLEsamples = "Samples",
    Effmodel = "ModelEff",
    Effsamples = "Samples"
  ),
  def = function(
    DLEmodel,
    DLEsamples,
    Effmodel,
    Effsamples,
    data,
    extrapolate = TRUE,
    showLegend = FALSE,
    ...
  ) {
    assert_logical(extrapolate)
    assert_logical(showLegend)
    ## Get Toxicity plot
    ## get the fit

    plotDLEData <- fit(
      DLEsamples,
      model = DLEmodel,
      data = data,
      quantiles = c(0.025, 0.975),
      middle = mean
    )

    ## make the plot
    gdata <-
      with(
        plotDLEData,
        data.frame(
          x = rep(dose, 3),
          y = c(middle, lower, upper) * 100,
          group = rep(c("mean", "lower", "upper"), each = nrow(plotDLEData)),
          Type = factor(
            c(
              rep(
                "Estimate",
                nrow(plotDLEData)
              ),
              rep(
                "95% Credible Interval",
                nrow(plotDLEData) * 2
              )
            ),
            levels = c(
              "Estimate",
              "95% Credible Interval"
            )
          )
        )
      )

    ret1 <- gdata %>%
      ggplot() +
      geom_line(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type
        ),
        colour = I("red"),
      ) +
      labs(
        x = "Dose Levels",
        y = "Probability of DLE [%]"
      ) +
      coord_cartesian(ylim = c(0, 100)) +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )
    ## only look at these dose levels for the plot:

    xLevels <- if (extrapolate) {
      seq_along(data@doseGrid)
    } else {
      1:max(data@xLevel)
    }

    ## get the plot data for the efficacy
    functionSamples <- matrix(
      nrow = size(Effsamples),
      ncol = length(xLevels)
    )
    ## evaluate the efficacy for all samples
    for (i in seq_along(xLevels)) {
      ## Now we want to evaluate for the following dose
      functionSamples[, i] <- efficacy(
        dose = data@doseGrid[xLevels[i]],
        model = Effmodel,
        samples = Effsamples
      )
    }
    ## extract mean curve
    meanCurve <- colMeans(functionSamples)

    ## extract quantiles
    quantiles <- c(0.025, 0.975)
    quantCurve <- apply(functionSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    plotEffData <- data.frame(
      dose = data@doseGrid[xLevels],
      mean = meanCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
    ## make the second plot
    ggdata <- with(
      plotEffData,
      data.frame(
        x = rep(dose, 3),
        y = c(mean, lower, upper),
        group = rep(c("mean", "lower", "upper"), each = nrow(plotEffData)),
        Type = factor(
          c(
            rep(
              "Estimate",
              nrow(plotEffData)
            ),
            rep(
              "95% Credible Interval",
              nrow(plotEffData) * 2
            )
          ),
          levels = c(
            "Estimate",
            "95% Credible Interval"
          )
        )
      )
    )

    plot2 <- ggdata %>%
      ggplot() +
      geom_line(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type
        ),
        colour = I("blue"),
      ) +
      labs(
        x = "Dose level",
        y = "Expected Efficacy"
      ) +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )

    ## arrange both plots side by side
    ret <- gridExtra::arrangeGrob(ret1, plot2, ncol = 2)
    return(ret)
  }
)

## ------------------------------------------------------------------------------
## Plot of the DLE and efficacy curve sides by side without  samples
## -----------------------------------------------------------------------------
#' Plot of the dose-DLE and dose-efficacy curve side by side given a DLE pseudo model
#' and a given pseudo efficacy model without DLE and efficacy samples
#'
#' @describeIn plotDualResponses Plot the DLE and efficacy curve side by side given a DLE model
#' and an efficacy model without any samples
#'
#' @example examples/Samples-method-plotDualResponsesNoSamples.R
#'
#' @export
#' @keywords methods
setMethod(
  "plotDualResponses",
  signature = signature(
    DLEmodel = "ModelTox",
    DLEsamples = "missing",
    Effmodel = "ModelEff",
    Effsamples = "missing"
  ),
  def = function(DLEmodel, Effmodel, data, ...) {
    ## Get Toxicity plot
    ## get the fit

    ## Make sure the model estimates are corresponds to the input data
    DLEmodel <- update(object = DLEmodel, data = data)
    Effmodel <- update(object = Effmodel, data = data)

    plotDLEData <- data.frame(
      dose = data@doseGrid,
      probDLE = prob(
        dose = data@doseGrid,
        model = DLEmodel
      )
    )
    ## make the plot
    gdata <- with(
      plotDLEData,
      data.frame(
        x = dose,
        y = probDLE,
        group = rep("Estimated DLE", each = nrow(plotDLEData)),
        Type = factor(
          rep("Estimated DLE", nrow(plotDLEData)),
          levels = "Estimated DLE"
        )
      )
    )

    plot1 <- ggplot(data = gdata, aes(x = x, y = y), group = group) +
      xlab("Dose Levels") +
      ylab(paste("Probability of DLE")) +
      ylim(c(0, 1)) +
      xlim(c(0, max(data@doseGrid))) +
      geom_line(colour = I("red"), linewidth = 1.5)

    plot1 <- plot1 +
      geom_line(linewidth = 1.5, colour = "red")

    ## only look at these dose levels for the plot:

    ## get the plot data for the efficacy
    plotEffData <- data.frame(
      dose = data@doseGrid,
      ExpEff = efficacy(
        dose = data@doseGrid,
        model = Effmodel
      )
    )

    ## make the second plot
    ggdata <- with(
      plotEffData,
      data.frame(
        x = dose,
        y = ExpEff,
        group = rep("Estimated Expected Efficacy", each = nrow(plotEffData)),
        Type = factor(
          rep("Estimated Expected Efficacy", nrow(plotEffData)),
          levels = "Estimated Expected Efficacy"
        )
      )
    )

    ## Get efficacy plot
    plot2 <- ggplot(data = ggdata, aes(x = x, y = y), group = group) +
      xlab("Dose Levels") +
      ylab(paste("Estimatimated Expected Efficacy")) +
      xlim(c(0, max(data@doseGrid))) +
      geom_line(colour = I("blue"), linewidth = 1.5)

    plot2 <- plot2 +
      geom_line(linewidth = 1.5, colour = "blue")

    ## arrange both plots side by side
    ret <- gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
    return(ret)
  }
)
## =======================================================================================================

## ----------------------------------------------------------------
## Get fitted DLT free survival (piecewise exponential model) based on
## the DA-CRM model
## -----------------------------------------------------------------
#' Get the fitted DLT free survival (piecewise exponential model).
#' This function returns a data frame with dose, middle, lower and upper
#' quantiles for the `PEM` curve. If hazard=TRUE,
#' @param object mcmc samples
#' @param model the mDA-CRM model
#' @param data the data input, a \code{\linkS4class{DataDA}} class object
#' @param quantiles the quantiles to be calculated (default: 0.025 and
#' 0.975)
#' @param middle the function for computing the middle point. Default:
#' \code{\link{mean}}
#' @param hazard should the the hazard over time be plotted based on the `PEM`? (not default)
#'   Otherwise ...
#' @param \dots additional arguments for methods
#'
#' @export
#' @keywords methods
setGeneric(
  "fitPEM",
  def = function(
    object,
    model,
    data,
    quantiles = c(0.025, 0.975),
    middle = mean,
    hazard = FALSE,
    ...
  ) {
    ## there should be no default method,
    ## therefore just forward to next method!
    standardGeneric("fitPEM")
  },
  valueClass = "data.frame"
)


#' Likelihood of DLTs in each interval
#'
#' This is a helper function for the `fitPEM` methods below.
#'
#' @param lambda the vector of piecewise hazards
#' @param Tmax the end of the time interval for DLTs
#' @return vector with the probabilities for DLTs within the intervals.
#'
#' @keywords internal
DLTLikelihood <- function(lambda, Tmax) {
  npiece <- length(lambda)
  h <- seq(from = 0L, to = Tmax, length = npiece + 1)

  # Length of each time interval;
  sT <- rep(0, npiece)

  for (i in 1:npiece) {
    sT[i] <- h[i + 1] - h[i]
  }

  # calculate the exponential part of the distribution:
  s_ij <- function(t, j) {
    if (t > h[j]) {
      min(t - h[j], h[j + 1] - h[j])
    } else {
      0
    }
  }

  # The cumulative hazard function
  expNmu <- function(t) {
    ret <- 1
    for (j in 1:npiece) {
      ret <- ret * exp(-lambda[j] * s_ij(t, j))
    }
    return(ret)
  }

  # CDF of the piecewise exponential
  piece_exp_cdf <- function(x) {
    1 - expNmu(x)
  }

  DLTFreeS <- function(x) {
    (expNmu(x) - expNmu(Tmax)) / piece_exp_cdf(Tmax)
  }

  pDLT <- rep(0, npiece + 1)

  for (i in 1:(npiece)) {
    pDLT[i] <- DLTFreeS(h[i]) - DLTFreeS(h[i + 1])
  }

  return(pDLT)
}

## --------------------------------------------------------------------
## Get fitted DLT free survival (piecewise exponential model) based on
## the DA-CRM model
## -------------------------------------------------------------
#' @describeIn fitPEM This method works for the \code{\linkS4class{DALogisticLogNormal}}
#' model class.
#' @example examples/Samples-method-fitPEM-DALogisticLogNormal.R
setMethod(
  "fitPEM",
  signature = signature(
    object = "Samples",
    model = "DALogisticLogNormal",
    data = "DataDA"
  ),
  def = function(
    object,
    model,
    data,
    quantiles = c(0.025, 0.975),
    middle = mean,
    hazard = FALSE,
    ...
  ) {
    ## some checks
    assert_probability_range(quantiles)
    assert_logical(hazard)
    ## Plot points
    points <- seq(0, data@Tmax, length = model@npiece + 1)
    ## first we have to get samples from the PEM
    ## at intercept points and 2 middel points between
    ## intercepts.
    PEMSamples <- matrix(
      nrow = size(object),
      ncol = length(points)
    )

    i_max <- max(seq_along(points))
    ## evaluate the probs, for all samples.

    # The PEM
    if (hazard == FALSE) {
      PEMSamples <- t(apply(object@data$lambda, 1, function(x) {
        fit <- DLTLikelihood(x, data@Tmax)
        return(fit)
      }))
    } else if (hazard == TRUE) {
      for (i in seq_along(points)) {
        if (i == i_max) {
          PEMSamples[, i_max] <- object@data$lambda[, model@npiece]
        } else {
          PEMSamples[, i] <- object@data$lambda[, i]
        }
      }
    }

    ## extract middle curve
    middleCurve <- apply(PEMSamples, 2L, FUN = middle)

    ## extract quantiles
    quantCurve <- apply(PEMSamples, 2L, quantile, prob = quantiles)

    ## now create the data frame
    ret <- data.frame(
      time = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )

    ## return it
    return(ret)
  }
)

## =======================================================================================================

## --------------------------------------------------
## Plot survival curve fit over time
## --------------------------------------------------

## todo: add example file
#' Plotting dose-toxicity model fits
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{DALogisticLogNormal}} object
#' @param data the \code{\linkS4class{DataDA}} object
#' @param hazard see \code{\link{fitPEM}} for the explanation
#' @param \dots not used
#' @param showLegend should the legend be shown? (default)
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-toxicity model fit
#'
#' @export
setMethod(
  "plot",
  signature = signature(
    x = "Samples",
    y = "DALogisticLogNormal"
  ),
  def = function(x, y, data, hazard = FALSE, ..., showLegend = TRUE) {
    ## check args
    assert_logical(showLegend)
    assert_logical(hazard)

    ## call the superclass method, to get the toxicity plot
    plot1 <- callNextMethod(x, y, data, showLegend = showLegend, ...)

    ## get the fit
    fitData <- fitPEM(
      x,
      model = y,
      data = data,
      quantiles = c(0.025, 0.975),
      middle = mean,
      hazard = hazard
    )

    ## make the plot
    Tpoints <- seq(0, data@Tmax, length = y@npiece + 1)
    plotData <-
      with(
        fitData,
        data.frame(
          x = rep(Tpoints, 3),
          y = c(middle, lower, upper) * 100,
          group = rep(c("mean", "lower", "upper"), each = nrow(fitData)),
          Type = factor(
            c(
              rep(
                "Estimate",
                nrow(fitData)
              ),
              rep(
                "95% Credible Interval",
                nrow(fitData) * 2
              )
            ),
            levels = c(
              "Estimate",
              "95% Credible Interval"
            )
          )
        )
      )
    plot2 <- plotData %>%
      ggplot() +
      geom_step(
        aes(
          x = x,
          y = y,
          group = group,
          linetype = Type
        ),
        colour = I("blue")
      ) +
      labs(
        x = "Time",
        y = if (hazard) "Hazard rate*100" else "Probability of DLT [%]"
      ) +
      coord_cartesian(
        ylim = if (hazard) range(plotData$y) else c(0, 100)
      )

    ret <- gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
    return(ret)
  }
)


## =======================================================================================================

# tidy ----

## Samples

## tidy-Samples ----

#' @rdname tidy
#' @aliases tidy-Samples
#' @example examples/Samples-method-tidy.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "Samples"),
  definition = function(x, ...) {
    rv <- lapply(
      slotNames(x),
      function(nm) {
        if (nm == "data") {
          lapply(
            names(x@data),
            function(nm) {
              as_tibble(get(x, nm))
            }
          ) %>%
            dplyr::bind_rows() %>%
            tidyr::pivot_wider(
              names_from = Parameter,
              values_from = value
            ) %>%
            dplyr::bind_cols(h_handle_attributes(get(x, names(x@data)[1])))
        } else {
          slot(x, nm) %>%
            tidy() %>%
            dplyr::bind_cols()
        }
      }
    )
    names(rv) <- c("data", "options")
    rv <- rv %>% h_tidy_class(x)
    rv
  }
)

#' @include helpers.R
#' @include Rules-validity.R
#' @include CrmPackClass-class.R
NULL

# NextBest ----

## class ----

#' `NextBest`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBest`] is a virtual class for finding next best dose, from which all
#' other specific next best dose classes inherit.
#'
#' @seealso [`NextBestMTD`], [`NextBestNCRM`], [`NextBestDualEndpoint`],
#'   [`NextBestThreePlusThree`], [`NextBestDualEndpoint`], [`NextBestMinDist`],
#'   [`NextBestInfTheory`], [`NextBestTD`], [`NextBestTDsamples`],
#'   [`NextBestMaxGain`], [`NextBestMaxGainSamples`].
#'
#' @aliases NextBest
#' @export
#'
setClass(
  Class = "NextBest",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname NextBest-class
#' @note Typically, end users will not use the `DefaultNextBest()` function.
#' @export
.DefaultNextBest <- function() {
  stop(paste0(
    "Class NextBest should not be instantiated directly.  Please use one of its subclasses instead."
  ))
}


# NextBestMTD ----

## class ----

#' `NextBestMTD`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMTD`] is the class for next best dose based on MTD estimate.
#'
#' @slot target (`proportion`)\cr target toxicity probability, except 0 or 1.
#' @slot derive (`function`)\cr a function which derives the final next best MTD
#'   estimate, based on vector of posterior MTD samples. It must therefore accept
#'   one and only one argument, which is a numeric vector, and return a number.
#'
#' @aliases NextBestMTD
#' @export
#'
.NextBestMTD <- setClass(
  Class = "NextBestMTD",
  slots = c(
    target = "numeric",
    derive = "function"
  ),
  prototype = prototype(
    target = 0.3,
    derive = function(mtd_samples) {
      quantile(mtd_samples, probs = 0.3)
    }
  ),
  contains = "NextBest",
  validity = v_next_best_mtd
)

## constructor ----

#' @rdname NextBestMTD-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param derive (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestMTD.R
#'
NextBestMTD <- function(target, derive) {
  .NextBestMTD(
    target = target,
    derive = derive
  )
}

## default constructor ----

#' @rdname NextBestMTD-class
#' @note Typically, end users will not use the `.DefaultNextBestMTD()` function.
#' @export
.DefaultNextBestMTD <- function() {
  NextBestMTD(
    target = 0.33,
    derive = function(mtd_samples) {
      quantile(mtd_samples, probs = 0.25)
    }
  )
}

# NextBestNCRM ----

## class ----

#' `NextBestNCRM`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestNCRM`] is the class for next best dose that finds the next dose
#' with high posterior probability to be in the target toxicity interval.
#'
#' @details 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 `overdose` category being below `max_overdose_prob`.
#' Next, within the admissible doses, the maximum probability to fall in the
#' `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 (`numeric`)\cr the target toxicity interval (limits included).
#' @slot overdose (`numeric`)\cr the overdose toxicity interval (lower limit
#'   excluded, upper limit included). It is used to filter probability samples.
#' @slot max_overdose_prob (`proportion`)\cr maximum overdose posterior
#'   probability that is allowed, except 0 or 1.
#'
#' @aliases NextBestNCRM
#' @export
#'
.NextBestNCRM <- setClass(
  Class = "NextBestNCRM",
  slots = c(
    target = "numeric",
    overdose = "numeric",
    max_overdose_prob = "numeric"
  ),
  prototype = prototype(
    target = c(0.2, 0.35),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  ),
  contains = "NextBest",
  validity = v_next_best_ncrm
)

## constructor ----

#' @rdname NextBestNCRM-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param overdose (`numeric`)\cr see slot definition.
#' @param max_overdose_prob (`proportion`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestNCRM.R
#'
NextBestNCRM <- function(target, overdose, max_overdose_prob) {
  .NextBestNCRM(
    target = target,
    overdose = overdose,
    max_overdose_prob = max_overdose_prob
  )
}

## default constructor ----

#' @rdname NextBestNCRM-class
#' @note Typically, end users will not use the `.DefaultNextBestNCRM()` function.
#' @export
.DefaultNextBestNCRM <- function() {
  NextBestNCRM(
    target = c(0.2, 0.35),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )
}

# NextBestNCRMLoss ----

## class ----

#' `NextBestNCRMLoss`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestNCRMLoss`] is the class based on NCRM rule and loss function.
#' This class is similar to [`NextBestNCRM`] class, but differences are the
#' addition of loss function and re-defined toxicity intervals, see each
#' toxicity interval documentation and the note for details. As in NCRM rule, first admissible doses are found,
#' which are those with probability to fall in overdose category being below
#' `max_overdose_prob`. Next, within the admissible doses, the loss function is
#' calculated, i.e. `losses` %*% `target`. Finally, the corresponding
#' dose with lowest loss function (Bayes risk) is recommended for the next dose.
#'
#' @slot target (`numeric`)\cr the target toxicity interval (limits included).
#'   It has to be a probability range excluding 0 and 1.
#' @slot overdose (`numeric`)\cr the overdose toxicity interval (lower limit
#'   excluded, upper limit included) or the excessive toxicity interval (lower
#'   limit excluded, upper limit included) if unacceptable is not provided.
#'   It has to be a probability range. It is used to filter probability samples.
#' @slot unacceptable (`numeric`)\cr an unacceptable toxicity
#'   interval (lower limit excluded, upper limit included). This must be
#'   specified if the `overdose` does not include 1. Otherwise, it is `c(1, 1)`
#'   (default), which is essentially a scalar equals 1. It has to be a
#'   probability range.
#' @slot losses (`numeric`)\cr a vector specifying the loss function. If the
#'   `unacceptable` is provided, the vector length must be 4, otherwise 3.
#'
#' @note The loss function should be a vector of either 3 or 4 values.
#'   This is because the loss function values must be specified for each
#'   interval, that is under-dosing, target toxicity, and overdosing toxicity or
#'   under-dosing, target toxicity, overdosing (excessive) toxicity, and
#'   unacceptable toxicity intervals.
#'
#' @aliases NextBestNCRMLoss
#' @export
#'
.NextBestNCRMLoss <- setClass(
  Class = "NextBestNCRMLoss",
  slots = c(
    unacceptable = "numeric",
    losses = "numeric"
  ),
  prototype = prototype(
    unacceptable = c(1, 1),
    losses = c(1, 0, 2)
  ),
  contains = "NextBestNCRM",
  validity = v_next_best_ncrm_loss
)

## constructor ----

#' @rdname NextBestNCRMLoss-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param overdose (`numeric`)\cr see slot definition.
#' @param unacceptable (`numeric`)\cr see slot definition.
#' @param max_overdose_prob (`proportion`)\cr see slot definition in [`NextBestNCRM`].
#' @param losses (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestNCRMLoss.R
#'
NextBestNCRMLoss <- function(
  target,
  overdose,
  unacceptable = c(1, 1),
  max_overdose_prob,
  losses
) {
  .NextBestNCRMLoss(
    target = target,
    overdose = overdose,
    unacceptable = unacceptable,
    max_overdose_prob = max_overdose_prob,
    losses = losses
  )
}

## default constructor ----

#' @rdname NextBestNCRMLoss-class
#' @note Typically, end users will not use the `.DefaultNextBestnCRMLoss()` function.
#' @export
.DefaultNextBestNCRMLoss <- function() {
  NextBestNCRMLoss(
    target = c(0.2, 0.35),
    overdose = c(0.35, 0.6),
    unacceptable = c(0.6, 1),
    max_overdose_prob = 0.25,
    losses = c(1, 0, 1, 2)
  )
}


# NextBestThreePlusThree ----

## class ----

#' `NextBestThreePlusThree`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestThreePlusThree`] is the class for next best dose that
#' implements the classical 3+3 dose recommendation. No input is required,
#' hence this class has no slots.
#'
#' @aliases NextBestThreePlusThree
#' @export
#'
.NextBestThreePlusThree <- setClass(
  Class = "NextBestThreePlusThree",
  contains = "NextBest"
)

## constructor ----

#' @rdname NextBestThreePlusThree-class
#'
#' @export
#' @examples
#' # Next best dose class object using the classical 3+3 design.
#' my_next_best <- NextBestThreePlusThree()
NextBestThreePlusThree <- function() {
  .NextBestThreePlusThree()
}

## default constructor ----

#' @rdname NextBestThreePlusThree-class
#' @note Typically, end users will not use the `.DefaultNextBestThreePlusThree()` function.
#' @export
.DefaultNextBestThreePlusThree <- function() {
  NextBestThreePlusThree()
}

# NextBestDualEndpoint ----

## class ----

#' `NextBestDualEndpoint`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestDualEndpoint`] is the class for next best dose that is based on the
#' dual endpoint model.
#'
#' @details Under this rule, at first admissible doses are found, which are those
#' with toxicity probability to fall in `overdose` category and being below
#' `max_overdose_prob`. Next, it picks (from the remaining admissible doses) the
#' one that maximizes the probability to be in the `target` biomarker range. By
#' default (`target_relative = TRUE`) the target is specified as relative to the
#' maximum biomarker level across the dose grid or relative to the `Emax`
#' parameter in case a parametric model was selected (i.e. [`DualEndpointBeta`],
#' [`DualEndpointEmax`]). However, if `target_relative = FALSE`, then the
#' absolute biomarker range can be used as a target.
#'
#' @slot target (`numeric`)\cr the biomarker target range that needs to be
#'   reached. For example, the target range \eqn{(0.8, 1.0)} and
#'   `target_relative = TRUE` means that we target a dose with at least
#'   \eqn{80\%} of maximum biomarker level. As an other example,
#'   \eqn{(0.5, 0.8)} would mean that we target a dose between \eqn{50\%} and
#'   \eqn{80\%} of the maximum biomarker level.
#' @slot overdose (`numeric`)\cr the overdose toxicity interval (lower limit
#'   excluded, upper limit included).
#' @slot max_overdose_prob (`proportion`)\cr maximum overdose probability that
#'   is allowed.
#' @slot target_relative (`flag`)\cr is `target` specified as relative? If
#'   `TRUE`, then the `target` is interpreted relative to the maximum, so it
#'   must be a probability range. Otherwise, the `target` is interpreted as
#'   absolute biomarker range.
#' @slot target_thresh (`proportion`)\cr a target probability threshold that
#'   needs to be fulfilled before the target probability will be used for
#'   deriving the next best dose (default to 0.01).
#'
#' @aliases NextBestDualEndpoint
#' @export
#'
.NextBestDualEndpoint <- setClass(
  Class = "NextBestDualEndpoint",
  slots = c(
    target = "numeric",
    overdose = "numeric",
    max_overdose_prob = "numeric",
    target_relative = "logical",
    target_thresh = "numeric"
  ),
  prototype = prototype(
    target = c(0.9, 1),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25,
    target_relative = TRUE,
    target_thresh = 0.01
  ),
  contains = "NextBest",
  validity = v_next_best_dual_endpoint
)

## constructor ----

#' @rdname NextBestDualEndpoint-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param overdose (`numeric`)\cr see slot definition.
#' @param max_overdose_prob (`proportion`)\cr see slot definition.
#' @param target_relative (`flag`)\cr see slot definition.
#' @param target_thresh (`proportion`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestDualEndpoint.R
#'
NextBestDualEndpoint <- function(
  target,
  overdose,
  max_overdose_prob,
  target_relative = TRUE,
  target_thresh = 0.01
) {
  .NextBestDualEndpoint(
    target = target,
    overdose = overdose,
    max_overdose_prob = max_overdose_prob,
    target_relative = target_relative,
    target_thresh = target_thresh
  )
}

## default constructor ----

#' @rdname NextBestDualEndpoint-class
#' @note Typically, end users will not use the `.DefaultNextBestDualEndpoint()` function.
#' @export
.DefaultNextBestDualEndpoint <- function() {
  NextBestDualEndpoint(
    target = c(200, 300),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25,
    target_relative = FALSE
  )
}

# NextBestMinDist ----

## class ----

#' `NextBestMinDist`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMinDist`] is the class for next best dose that is based on minimum
#' distance to target probability.
#'
#' @slot target (`proportion`)\cr single target toxicity probability, except
#'   0 or 1.
#'
#' @aliases NextBestMinDist
#' @export
#'
.NextBestMinDist <- setClass(
  Class = "NextBestMinDist",
  slots = c(
    target = "numeric"
  ),
  prototype = prototype(
    target = 0.3
  ),
  contains = "NextBest",
  validity = v_next_best_min_dist
)

## constructor ----

#' @rdname NextBestMinDist-class
#'
#' @param target (`proportion`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestMinDist.R
#'
NextBestMinDist <- function(target) {
  .NextBestMinDist(target = target)
}

## default constructor ----

#' @rdname NextBestMinDist-class
#' @note Typically, end users will not use the `.DefaultNextBestMinDist()` function.
#' @export
.DefaultNextBestMinDist <- function() {
  NextBestMinDist(target = 0.3)
}

# NextBestInfTheory ----

## class ----

#' `NextBestInfTheory`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestInfTheory`] is the class for next best dose that is based on
#' information theory as proposed in https://doi.org/10.1002/sim.8450.
#'
#' @slot target (`proportion`)\cr target toxicity probability, except 0 or 1.
#' @slot asymmetry (`number`)\cr value of the asymmetry exponent in the
#'   divergence function that describes the rate of penalization for overly
#'   toxic does. It must be a value from \eqn{(0, 2)} interval.
#'
#' @aliases NextBestInfTheory
#' @export
#'
.NextBestInfTheory <- setClass(
  Class = "NextBestInfTheory",
  slots = c(
    target = "numeric",
    asymmetry = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    asymmetry = 1
  ),
  contains = "NextBest",
  validity = v_next_best_inf_theory
)

## constructor ----

#' @rdname NextBestInfTheory-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param asymmetry (`number`)\cr see slot definition.
#'
#' @export
#'
NextBestInfTheory <- function(target, asymmetry) {
  .NextBestInfTheory(target = target, asymmetry = asymmetry)
}

## default constructor ----

#' @rdname NextBestInfTheory-class
#' @note Typically, end users will not use the `.DefaultNextBestInfTheory()` function.
#' @export
.DefaultNextBestInfTheory <- function() {
  NextBestInfTheory(0.33, 1.2)
}

# NextBestTD ----

## class ----

#' `NextBestTD`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestTD`] is the class to find a next best dose based on pseudo
#' DLT model without samples. Namely, it is to find two next best doses, one
#' for allocation during the trial and the second for final recommendation at
#' the end of a trial without involving any samples, i.e. only DLT responses
#' will be incorporated for the dose-allocation. This is based solely on the
#' probabilities of the occurrence of a DLT obtained by using the modal estimates
#' of the model parameters. There are two target probabilities of the
#' occurrence of a DLT that must be specified: target probability to be used
#' during the trial and target probability to be used at the end of the trial.
#' It is suitable to use it only with the [`ModelTox`] model class.
#'
#' @slot prob_target_drt (`proportion`)\cr the target probability (except 0 or 1)
#'   of the occurrence of a DLT to be used during the trial.
#' @slot prob_target_eot (`proportion`)\cr the target probability (except 0 or 1)
#'   of the occurrence of a DLT to be used at the end of the trial.
#'
#' @aliases NextBestTD
#' @export
#'
.NextBestTD <- setClass(
  Class = "NextBestTD",
  slots = c(
    prob_target_drt = "numeric",
    prob_target_eot = "numeric"
  ),
  prototype = prototype(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3
  ),
  contains = "NextBest",
  validity = v_next_best_td
)

## default constructor ----

#' @rdname NextBestTD-class
#' @note Typically, end users will not use the `.DefaultNextBestTD()` function.
#' @export
.DefaultNextBestTD <- function() {
  NextBestTD(0.35, 0.3)
}

## constructor ----

#' @rdname NextBestTD-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition.
#' @param prob_target_eot (`proportion`)\cr see slot definition.
#'
#' @export
#' @examples
#' my_next_best <- NextBestTD(0.35, 0.3)
NextBestTD <- function(prob_target_drt, prob_target_eot) {
  .NextBestTD(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot
  )
}

# NextBestTDsamples ----

## class ----

#' `NextBestTDsamples`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestTDsamples`] is the class to find a next best dose based on Pseudo
#' DLT model with samples. Namely, it is to find two next best doses, one
#' for allocation during the trial and the second for final recommendation at
#' the end of a trial. Hence, there are two target probabilities of the
#' occurrence of a DLT that must be specified: target probability to be used
#' during the trial and target probability to be used at the end of the trial.
#'
#' @slot derive (`function`)\cr derives, based on a vector of posterior dose
#'   samples, the target dose that has the probability of the occurrence of
#'   DLT equals to either the `prob_target_drt` or `prob_target_eot`. It must
#'   therefore accept one and only one argument, which is a numeric vector, and
#'   return a number.
#'
#' @aliases NextBestTDsamples
#' @export
#'
.NextBestTDsamples <- setClass(
  Class = "NextBestTDsamples",
  slots = c(
    derive = "function"
  ),
  prototype = prototype(
    derive = function(dose_samples) {
      quantile(dose_samples, prob = 0.3)
    }
  ),
  contains = "NextBestTD",
  validity = v_next_best_td_samples
)

## constructor ----

#' @rdname NextBestTDsamples-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition in [`NextBestTD`].
#' @param prob_target_eot (`proportion`)\cr see slot definition in [`NextBestTD`].
#' @param derive (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestTDsamples.R
#'
NextBestTDsamples <- function(prob_target_drt, prob_target_eot, derive) {
  .NextBestTDsamples(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot,
    derive = derive
  )
}

## default constructor ----

#' @rdname NextBestTDsamples-class
#' @note Typically, end users will not use the `.DefaultNextBestTDsamples()` function.
#' @export
.DefaultNextBestTDsamples <- function() {
  NextBestTDsamples(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(samples) {
      as.numeric(quantile(samples, probs = 0.3))
    }
  )
}


# NextBestMaxGain ----

## class ----

#' `NextBestMaxGain`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMaxGain`] is the class to find a next best dose with maximum gain
#' value based on a pseudo DLT and efficacy models without samples. It is based
#' solely on the probabilities of the occurrence of a DLT and the values
#' of the mean efficacy responses obtained by using the modal estimates of the
#' DLT and efficacy model parameters. There are two target probabilities of the
#' occurrence of a DLT that must be specified: target probability to be used
#' during the trial and target probability to be used at the end of the trial.
#' It is suitable to use it only with the [`ModelTox`] model and [`ModelEff`]
#' classes (except [`EffFlexi`]).
#'
#' @slot prob_target_drt (`proportion`)\cr the target probability of the
#'   occurrence of a DLT to be used during the trial.
#' @slot prob_target_eot (`proportion`)\cr the target probability of the
#'   occurrence of a DLT to be used at the end of the trial.
#'
#' @aliases NextBestMaxGain
#' @export
#'
.NextBestMaxGain <- setClass(
  Class = "NextBestMaxGain",
  slots = c(
    prob_target_drt = "numeric",
    prob_target_eot = "numeric"
  ),
  prototype = prototype(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3
  ),
  contains = "NextBest",
  validity = v_next_best_td
)

## constructor ----

#' @rdname NextBestMaxGain-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition.
#' @param prob_target_eot (`proportion`)\cr see slot definition.
#'
#' @export
#' @examples
#' my_next_best <- NextBestMaxGain(0.35, 0.3)
NextBestMaxGain <- function(prob_target_drt, prob_target_eot) {
  .NextBestMaxGain(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot
  )
}

## default constructor ----

#' @rdname NextBestMaxGain-class
#' @note Typically, end users will not use the `.DefaultNextBestMaxGain()` function.
#' @export
.DefaultNextBestMaxGain <- function() {
  NextBestMaxGain(0.35, 0.3)
}

# NextBestMaxGainSamples ----

## class ----

#' `NextBestMaxGainSamples`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMaxGainSamples`] is the class to find a next best dose with maximum
#' gain value based on a pseudo DLT and efficacy models and DLT and efficacy
#' samples. There are two target probabilities of the occurrence of a DLT that
#' must be specified: target probability to be used during the trial and target
#' probability to be used at the end of the trial.
#' It is suitable to use it only with the [`ModelTox`] model and [`ModelEff`]
#' classes.
#'
#' @slot derive (`function`)\cr derives, based on a vector of posterior dose
#'   samples, the target dose that has the probability of the occurrence of
#'   DLT equals to either the `prob_target_drt` or `prob_target_eot`. It must
#'   therefore accept one and only one argument, which is a numeric vector, and
#'   return a number.
#' @slot mg_derive (`function`)\cr derives, based on a vector of posterior dose
#'   samples that give the maximum gain value, the final next best estimate of
#'   the dose that gives the maximum gain value. It must therefore accept one
#'   and only one argument, which is a numeric vector, and return a number.
#'
#' @aliases NextBestMaxGainSamples
#' @export
#'
.NextBestMaxGainSamples <- setClass(
  Class = "NextBestMaxGainSamples",
  slots = c(
    derive = "function",
    mg_derive = "function"
  ),
  prototype = prototype(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(dose_samples) {
      as.numeric(quantile(dose_samples, prob = 0.3))
    },
    mg_derive = function(dose_samples) {
      as.numeric(quantile(dose_samples, prob = 0.5))
    }
  ),
  contains = "NextBestMaxGain",
  validity = v_next_best_max_gain_samples
)

## constructor ----

#' @rdname NextBestMaxGainSamples-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition in [`NextBestMaxGain`].
#' @param prob_target_eot (`proportion`)\cr see slot definition in [`NextBestMaxGain`].
#' @param derive (`function`)\cr see slot definition.
#' @param mg_derive (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestMaxGainSamples.R
#'
NextBestMaxGainSamples <- function(
  prob_target_drt,
  prob_target_eot,
  derive,
  mg_derive
) {
  .NextBestMaxGainSamples(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot,
    derive = derive,
    mg_derive = mg_derive
  )
}

## default constructor ----

#' @rdname NextBestMaxGainSamples-class
#' @note Typically, end users will not use the `.DefaultNextBestMaxGainSamples()` function.
#' @export
.DefaultNextBestMaxGainSamples <- function() {
  NextBestMaxGainSamples(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(samples) {
      as.numeric(quantile(samples, prob = 0.3))
    },
    mg_derive = function(mg_samples) {
      as.numeric(quantile(mg_samples, prob = 0.5))
    }
  )
}

# NextBestProbMTDLTE ----

## class ----

#' `NextBestProbMTDLTE`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestProbMTDLTE`] is the class of finding a next best dose that selects
#' the dose with the highest probability of having a toxicity rate less or equal
#' to the toxicity target.
#' The dose is determined by calculating the posterior toxicity probability
#' for each dose per iteration and select the maximum dose that has a toxicity
#' probability below or equal to the target. The dose with the highest frequency
#' of being selected as MTD across iterations is the next best dose. Placebo
#' is not considered in the calculation and removed from the dose grid for
#' any calculations.
#'
#' @slot target (`numeric`)\cr the target toxicity probability.
#'
#' @aliases NextBestProbMTDLTE
#' @export
#'
.NextBestProbMTDLTE <- setClass(
  Class = "NextBestProbMTDLTE",
  slots = c(target = "numeric"),
  prototype = prototype(target = 0.3),
  contains = "NextBest",
  validity = v_next_best_prob_mtd_lte
)

## constructor ----

#' @rdname NextBestProbMTDLTE-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestProbMTDLTE.R
#'
NextBestProbMTDLTE <- function(target) {
  .NextBestProbMTDLTE(target = target)
}

## default constructor ----

#' @rdname NextBestProbMTDLTE-class
#' @note Typically, end users will not use the `.DefaultNextBestProbMTDLTE()` function.
#' @export
.DefaultNextBestProbMTDLTE <- function() {
  NextBestProbMTDLTE(target = 0.3)
}

# NextBestProbMTDMinDist ----

## class ----

#' `NextBestProbMTDMinDist`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestProbMTDMinDist`] is the class of finding a next best dose that selects
#' the dose with the highest probability of having a toxicity rate with the
#' smallest distance to the toxicity target.
#' The dose is determined by calculating the posterior toxicity probability
#' for each dose per iteration and select the dose that has the smallest toxicity
#' probability distance to the target. The dose with the highest frequency
#' of being selected as MTD across iterations is the next best dose. Placebo
#' is not considered as the next dose and for that reason not used in
#' calculations. I.e. for placebo the toxicity probability distance to target
#' is not calculated and taken into account for determination of the next dose.
#'
#' @slot target (`numeric`)\cr the target toxicity probability.
#'
#' @aliases NextBestProbMTDMinDist
#' @export
#'
.NextBestProbMTDMinDist <- setClass(
  Class = "NextBestProbMTDMinDist",
  slots = c(target = "numeric"),
  prototype = prototype(target = 0.3),
  contains = "NextBest",
  validity = v_next_best_prob_mtd_min_dist
)

## constructor ----

#' @rdname NextBestProbMTDMinDist-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestProbMTDMinDist.R
#'
NextBestProbMTDMinDist <- function(target) {
  .NextBestProbMTDMinDist(target = target)
}

## default constructor ----

#' @rdname NextBestProbMTDMinDist-class
#' @note Typically, end users will not use the `.DefaultNextBestProbMTDMinDist()` function.
#' @export
.DefaultNextBestProbMTDMinDist <- function() {
  NextBestProbMTDMinDist(target = 0.3)
}

# NextBestOrdinal ----

## class ----

#' `NextBestOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestOrdinal`] is the class for applying a standard `NextBest` rule to
#' the results of an ordinal CRM trial.
#'
#' @slot grade (`integer`)\cr the toxicity grade to which the `rule` should be
#' applied.
#' @slot rule (`NextBest`)\cr the standard `NextBest` rule to be applied
#'
#' @aliases NextBestOrdinal
#' @export
#'
.NextBestOrdinal <- setClass(
  Class = "NextBestOrdinal",
  slots = c(grade = "numeric", rule = "NextBest"),
  contains = "NextBest",
  validity = v_next_best_ordinal
)

## constructor ----

#' @rdname NextBestOrdinal-class
#'
#' @param grade (`numeric`)\cr see slot definition.
#' @param rule (`NextBest`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestOrdinal.R
#'
NextBestOrdinal <- function(grade, rule) {
  .NextBestOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname NextBestOrdinal-class
#' @note Typically, end users will not use the `.DefaultNextBestOrdinal()` function.
#' @export
.DefaultNextBestOrdinal <- function() {
  NextBestOrdinal(
    grade = 1L,
    rule = NextBestMTD(
      0.25,
      function(mtd_samples) {
        quantile(mtd_samples, probs = 0.25)
      }
    )
  )
}

# Increments ----

## class ----

#' `Increments`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Increments`] is a virtual class for controlling increments, from which all
#' other specific increments classes inherit.
#'
#' @seealso [`IncrementsRelative`], [`IncrementsRelativeDLT`],
#'   [`IncrementsDoseLevels`], [`IncrementsHSRBeta`], [`IncrementsMin`].
#'
#' @aliases Increments
#' @export
#'
setClass(
  Class = "Increments",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname Increments-class
#' @note Typically, end users will not use the `.DefaultIncrements()` function.
#' @export
.DefaultIncrements <- function() {
  stop(paste0(
    "Class Increments cannot be instantiated directly.  Please use one of its subclasses instead."
  ))
}


# IncrementsRelative ----

## class ----

#' `IncrementsRelative`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsRelative`] is the class for increments control based on relative
#' differences in intervals.
#'
#' @slot intervals (`numeric`)\cr a vector with the left bounds of the relevant
#'   intervals. For example, `intervals  = c(0, 50, 100)` specifies three intervals:
#'   \eqn{(0, 50)}, \eqn{[50, 100)} and \eqn{[100, +Inf)}. That means, the right
#'   bound of the intervals are exclusive to the interval and the last interval
#'   goes from the last value to infinity.
#' @slot increments (`numeric`)\cr a vector of the same length with the maximum
#'   allowable relative increments in the `intervals`.
#'
#' @aliases IncrementsRelative
#' @export
#'
.IncrementsRelative <- setClass(
  Class = "IncrementsRelative",
  slots = c(
    intervals = "numeric",
    increments = "numeric"
  ),
  prototype = prototype(
    intervals = c(0, 2),
    increments = c(2, 1)
  ),
  contains = "Increments",
  validity = v_increments_relative
)

## constructor ----

#' @rdname IncrementsRelative-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param increments (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-IncrementsRelative.R
#'
IncrementsRelative <- function(intervals, increments) {
  .IncrementsRelative(
    intervals = intervals,
    increments = increments
  )
}

## default constructor ----

#' @rdname IncrementsRelative-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelative()` function.
#' @export
.DefaultIncrementsRelative <- function() {
  IncrementsRelative(intervals = c(0, 20), increments = c(1, 0.33))
}


# IncrementsRelativeDLT ----

## class ----

#' `IncrementsRelativeDLT`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsRelativeDLT`] is the class for increments control based on
#' relative differences in terms of DLTs.
#'
#' @slot intervals (`integer`)\cr a vector with the left bounds of the
#'   relevant DLT intervals. For example, `intervals  = c(0, 1, 3)` specifies
#'   three intervals (sets of DLTs: first, 0 DLT; second 1 or 2 DLTs; and the third
#'   one, at least 3 DLTs. That means, the right bound of the intervals are
#'   exclusive to the interval and the last interval goes from the last value to
#'   infinity.
#' @slot increments (`numeric`)\cr a vector of maximum allowable relative
#'   increments corresponding to `intervals`. IT must be of the same length
#'   as the length of `intervals`.
#'
#' @note This considers all DLTs across all cohorts observed so far.
#'
#' @seealso [IncrementsRelativeDLTCurrent] which only considers the DLTs
#'   in the current cohort.
#'
#' @aliases IncrementsRelativeDLT
#' @export
#'
.IncrementsRelativeDLT <- setClass(
  Class = "IncrementsRelativeDLT",
  slots = representation(
    intervals = "integer",
    increments = "numeric"
  ),
  prototype = prototype(
    intervals = c(0L, 1L),
    increments = c(2, 1)
  ),
  contains = "Increments",
  validity = v_increments_relative_dlt
)

## constructor ----

#' @rdname IncrementsRelativeDLT-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param increments (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-IncrementsRelativeDLT.R
#'
IncrementsRelativeDLT <- function(intervals, increments) {
  assert_integerish(intervals, lower = 0, any.missing = FALSE)
  assert_numeric(increments, any.missing = FALSE, lower = 0)

  .IncrementsRelativeDLT(
    intervals = as.integer(intervals),
    increments = increments
  )
}

## default constructor ----

#' @rdname IncrementsRelativeDLT-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelativeDLT()` function.
#' @export
.DefaultIncrementsRelativeDLT <- function() {
  IncrementsRelativeDLT(intervals = c(0L, 1L, 3L), increments = c(1, 0.33, 0.2))
}

# IncrementsRelativeDLTCurrent ----

## class ----

#' `IncrementsRelativeDLTCurrent`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsRelativeDLTCurrent`] is the class for increments control based on
#' relative differences and current DLTs. The class is based on the number of
#' DLTs observed in the current cohort, but not cumulatively over all cohorts
#' so far.
#'
#' @seealso [IncrementsRelativeDLT].
#'
#' @aliases IncrementsRelativeDLTCurrent
#' @export
#'
.IncrementsRelativeDLTCurrent <- setClass(
  Class = "IncrementsRelativeDLTCurrent",
  contains = "IncrementsRelativeDLT"
)

## constructor ----

#' @rdname IncrementsRelativeDLTCurrent-class
#'
#' @inheritParams IncrementsRelativeDLT
#'
#' @export
#' @example examples/Rules-class-IncrementsRelativeDLTCurrent.R
#'
IncrementsRelativeDLTCurrent <- function(
  intervals = c(0L, 1L),
  increments = c(2L, 1L)
) {
  assert_integerish(intervals, lower = 0, any.missing = FALSE)
  assert_numeric(increments, any.missing = FALSE, lower = 0)

  .IncrementsRelativeDLTCurrent(
    intervals = as.integer(intervals),
    increments = increments
  )
}

## default constructor ----

#' @rdname IncrementsRelativeDLTCurrent-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelativeDLTCurrent()` function.
#' @export
.DefaultIncrementsRelativeDLTCurrent <- function() {
  # nolint
  IncrementsRelativeDLTCurrent(
    intervals = c(0L, 1L, 3L),
    increments = c(1, 0.33, 0.2)
  )
}

# IncrementsRelativeParts ----

## class ----

#' `IncrementsRelativeParts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsRelativeParts`] is the class for increments control based on
#' relative differences in intervals, with special rules for part 1 and
#' beginning of part 2.
#'
#' @details This class works only in conjunction with [`DataParts`] objects. If
#' part 2 will just be started in the next cohort, then the next maximum dose
#' will be either `dlt_start` (e.g. -1) shift of the last part 1 dose in case
#' of a DLT in part 1, or `clean_start` shift (e.g. -1) in case of no DLTs in
#' part 1, given that `clean_start <= 0` (see description of `clean_start`
#' slot for more details). 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
#' `part1Ladder` slot of the data object. If part 2 has been started before,
#' the usual relative increment rules apply, see [`IncrementsRelative`].
#'
#' @slot dlt_start (`integer`)\cr a scalar, the dose level increment for starting
#'   part 2 in case of at least one DLT event in part 1.
#' @slot clean_start (`integer`)\cr a scalar, the dose level increment for
#'   starting part 2 in case of no DLTs in part 1. If `clean_start <= 0`,
#'   then the part 1 ladder will be used to find the maximum next dose.
#'   Otherwise, the relative increment rules will be applied to find the next
#'   maximum dose level.
#'
#' @note We require that `clean_start >= dlt_start`. However, this precondition
#'   is not a prerequisite for any function (except of the class' validation
#'   function) that works with objects of this class. It is rather motivated by
#'   the semantics. That is, if we observe a DLT in part 1, we cannot be more
#'   aggressive than in case of a clean part 1 without DLT.
#'
#' @aliases IncrementsRelativeParts
#' @export
#'
.IncrementsRelativeParts <- setClass(
  Class = "IncrementsRelativeParts",
  slots = representation(
    dlt_start = "integer",
    clean_start = "integer"
  ),
  prototype = prototype(
    dlt_start = -1L,
    clean_start = 1L
  ),
  contains = "IncrementsRelative",
  validity = v_increments_relative_parts
)

## constructor ----

#' @rdname IncrementsRelativeParts-class
#'
#' @param dlt_start (`count`)\cr see slot definition.
#' @param clean_start (`count`)\cr see slot definition.
#' @inheritDotParams IncrementsRelative
#'
#' @export
#' @example examples/Rules-class-IncrementsRelative-DataParts.R
#'
IncrementsRelativeParts <- function(dlt_start, clean_start, ...) {
  assert_integerish(dlt_start)
  assert_integerish(clean_start)

  .IncrementsRelativeParts(
    dlt_start = as.integer(dlt_start),
    clean_start = as.integer(clean_start),
    ...
  )
}

## default constructor ----

#' @rdname IncrementsRelativeParts-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelativeParts()` function.
#' @export
.DefaultIncrementsRelativeParts <- function() {
  IncrementsRelativeParts(dlt_start = 0L, clean_start = 1L)
}

# IncrementsDoseLevels ----

## class ----

#' `IncrementsDoseLevels`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsDoseLevels`] is the class for increments control based on the
#' number of dose levels.
#'
#' @slot levels (`count`)\cr maximum number of dose levels to increment for
#'   the next dose. It defaults to 1, which means that no dose skipping is
#'   allowed, i.e. the next dose can be maximum one level higher than the current
#'   base dose. The current base dose level is the dose level used to increment
#'   from (see `basis_level` parameter).
#' @slot basis_level (`string`)\cr defines the current base dose level. It can
#'   take one out of two possible values: `last` or `max`.
#'   If `last` is specified (default), the current base dose level is set to the
#'   last dose given. If `max` is specified, then the current base dose level is
#'   set to the maximum dose level given.
#'
#' @aliases IncrementsDoseLevels
#' @export
#'
.IncrementsDoseLevels <- setClass(
  Class = "IncrementsDoseLevels",
  slots = representation(
    levels = "integer",
    basis_level = "character"
  ),
  prototype = prototype(
    levels = 1L,
    basis_level = "last"
  ),
  contains = "Increments",
  validity = v_increments_dose_levels
)

## constructor ----

#' @rdname IncrementsDoseLevels-class
#'
#' @param levels (`count`)\cr see slot definition.
#' @param basis_level (`string`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-IncrementsDoseLevels.R
#'
IncrementsDoseLevels <- function(levels = 1L, basis_level = "last") {
  assert_count(levels, positive = TRUE)
  assert_string(basis_level)
  assert_subset(basis_level, c("last", "max"))

  .IncrementsDoseLevels(
    levels = as.integer(levels),
    basis_level = basis_level
  )
}

## default constructor ----

#' @rdname IncrementsDoseLevels-class
#' @note Typically, end users will not use the `.DefaultIncrementsDoseLevels()` function.
#' @export
.DefaultIncrementsDoseLevels <- function() {
  IncrementsDoseLevels(levels = 2L, basis_level = "last")
}

# IncrementsHSRBeta ----

## class ----

#' `IncrementsHSRBeta`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsHSRBeta`] is a class for limiting further increments using
#' a Hard Safety Rule based on the Bin-Beta model.
#' Increment control is based on the number of observed DLTs and number of
#' subjects at each dose level. The probability of toxicity is calculated
#' using a Bin-Beta model with prior (a,b). If the probability exceeds
#' the threshold for a given dose, that dose and all doses above are excluded
#' from further escalation.
#' This is a hard safety rule that limits further escalation based on the
#' observed data per dose level, independent from the underlying model.
#'
#' @slot target (`proportion`)\cr the target toxicity, except
#'   0 or 1.
#' @slot prob (`proportion`)\cr the threshold probability (except 0 or 1) for
#'   a dose being toxic.
#' @slot a (`number`)\cr shape parameter \eqn{a > 0} of probability distribution
#'   Beta (a,b).
#' @slot b (`number`)\cr shape parameter \eqn{b > 0} of probability distribution
#'   Beta (a,b).
#'
#' @aliases IncrementsHSRBeta
#' @export
#'
.IncrementsHSRBeta <- setClass(
  Class = "IncrementsHSRBeta",
  slots = c(
    target = "numeric",
    prob = "numeric",
    a = "numeric",
    b = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    prob = 0.95,
    a = 1,
    b = 1
  ),
  contains = "Increments",
  validity = v_increments_hsr_beta
)

## constructor ----

#' @rdname IncrementsHSRBeta-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param a (`number`)\cr see slot definition.
#' @param b (`number`)\cr see slot definition.
#'
#' @example examples/Rules-class-IncrementsHSRBeta.R
#' @export
#'
IncrementsHSRBeta <- function(target = 0.3, prob = 0.95, a = 1, b = 1) {
  .IncrementsHSRBeta(
    target = target,
    prob = prob,
    a = a,
    b = b
  )
}

## default constructor ----

#' @rdname IncrementsHSRBeta-class
#' @note Typically, end users will not use the `.DefaultIncrementsHSRBeta()` function.
#' @export
.DefaultIncrementsHSRBeta <- function() {
  IncrementsHSRBeta(target = 0.3, prob = 0.95)
}

# IncrementsMin ----

## class ----

#' `IncrementsMin`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsMin`] is the class that combines multiple increment rules with
#' the `minimum` operation. Slot `increments_list` contains all increment rules,
#' which are itself the objects of class [`Increments`]. The minimum of these
#' individual increments is taken to give the final maximum increment.
#'
#' @slot increments_list (`list`)\cr list with increment rules.
#'
#' @aliases IncrementsMin
#' @export
#'
.IncrementsMin <- setClass(
  Class = "IncrementsMin",
  slots = c(increments_list = "list"),
  prototype = prototype(
    increments_list = list(
      IncrementsRelativeDLT(intervals = c(0L, 1L), increments = c(2, 1)),
      IncrementsRelative(intervals = c(0, 2), increments = c(2, 1))
    )
  ),
  contains = "Increments",
  validity = v_increments_min
)

## constructor ----

#' @rdname IncrementsMin-class
#'
#' @param increments_list (`list`)\cr see slot definition.
#'
#' @example examples/Rules-class-IncrementsMin.R
#' @export
#'
IncrementsMin <- function(increments_list) {
  .IncrementsMin(increments_list = increments_list)
}
## default constructor ----

#' @rdname IncrementsMin-class
#' @note Typically, end users will not use the `.DefaultIncrementsMin()` function.
#' @export
.DefaultIncrementsMin <- function() {
  IncrementsMin(
    increments_list = list(
      IncrementsRelativeDLT(
        intervals = c(0, 1, 3),
        increments = c(1, 0.33, 0.2)
      ),
      IncrementsRelative(intervals = c(0, 20), increments = c(1, 0.33))
    )
  )
}

# IncrementsOrdinal ----

## class ----

#' `IncrementsOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsOrdinal`] is the class for applying a standard `Increments` rule to
#' the results of an ordinal CRM trial.
#'
#' @slot grade (`integer`)\cr the toxicity grade to which the `rule` should be
#' applied.
#' @slot rule (`Increments`)\cr the standard `Increments` rule to be applied
#'
#' @aliases IncrementsOrdinal
#' @export
#'
.IncrementsOrdinal <- setClass(
  Class = "IncrementsOrdinal",
  slots = c(grade = "numeric", rule = "Increments"),
  contains = "Increments",
  validity = v_increments_ordinal
)

## constructor ----

#' @rdname IncrementsOrdinal-class
#'
#' @param grade (`numeric`)\cr see slot definition.
#' @param rule (`Increments`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-IncrementsOrdinal.R
#'
IncrementsOrdinal <- function(grade, rule) {
  .IncrementsOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname IncrementsOrdinal-class
#' @note Typically, end users will not use the `.DefaultIncrementsOrdinal()` function.
#' @export
.DefaultIncrementsOrdinal <- function() {
  IncrementsOrdinal(
    grade = 1L,
    rule = IncrementsRelative(intervals = c(0, 20), increments = c(1, 0.33))
  )
}

# IncrementsMaxToxProb ----

## class ----

#' `IncrementsMaxToxProb`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsMaxToxProb`] is the class for increments control based on
#' probability of toxicity
#'
#' @slot prob (`numeric`)\cr See Usage Notes below.
#'
#' @section Usage Notes:
#' For binary models, `prob` should be a scalar probability.
#'
#' For ordinal models, `prob` should be a named vector containing the maximum
#' permissible probability of toxicity by grade.  The names should match the
#' names of the `yCategories` slot of the associated `DataOrdinal` object.
#'
#' @aliases IncrementsMaxToxProb
#' @export
#'
.IncrementsMaxToxProb <- setClass(
  Class = "IncrementsMaxToxProb",
  slots = c(
    prob = "numeric"
  ),
  prototype = prototype(
    prob = c("DLAE" = 0.2, "DLT" = 0.05)
  ),
  contains = "Increments",
  validity = v_increments_maxtoxprob
)

## constructor ----

#' @rdname IncrementsMaxToxProb-class
#'
#' @param prob (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-IncrementsMaxToxProb.R
#'
IncrementsMaxToxProb <- function(prob) {
  .IncrementsMaxToxProb(
    prob = prob
  )
}

## default constructor ----

#' @rdname IncrementsMaxToxProb-class
#' @note Typically, end users will not use the `.DefaultIncrementsMaxToxProb()` function.
#' @export
.DefaultIncrementsMaxToxProb <- function() {
  IncrementsMaxToxProb(prob = c("DLAE" = 0.2, "DLT" = 0.05))
}

# Stopping ----

## class ----

#' `Stopping`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Stopping`] is a class for stopping rules.
#'
#' @slot report_label (`string`)\cr a label for the stopping report. The meaning
#'   of this parameter is twofold. If it is equal to `NA_character_` (default),
#'   the `report_label` will not be used in the report at all. Otherwise, if it
#'   is specified as an empty character (i.e. `character(0)`) in a user constructor,
#'   then a default, class-specific label will be created for this slot.
#'   Finally, for the remaining cases, a user can provide a custom label.
#'
#' @seealso [`StoppingList`], [`StoppingCohortsNearDose`], [`StoppingPatientsNearDose`],
#'   [`StoppingMinCohorts`], [`StoppingMinPatients`], [`StoppingTargetProb`],
#'   [`StoppingMTDdistribution`], [`StoppingTargetBiomarker`], [`StoppingHighestDose`]
#'   [`StoppingMTDCV`], [`StoppingLowestDoseHSRBeta`], [`StoppingSpecificDose`].
#'
#' @aliases Stopping
#' @export
#'
setClass(
  Class = "Stopping",
  contains = "CrmPackClass",
  slots = c(report_label = "character"),
  prototype = prototype(report_label = character(0))
)


## default constructor ----

#' @rdname CohortSize-class
#' @note Typically, end users will not use the `DefaultCohortSize()` function.
#' @export
.DefaultCohortSize <- function() {
  stop(paste0(
    "Class CohortSize should not be instantiated directly.  Please use one of its subclasses instead."
  ))
}

# StoppingMissingDose ----

## class ----

#' `StoppingMissingDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingMissingDose`] is the class for stopping based on NA returned by
#'  next best dose.
#'
#' @aliases StoppingMissingDose
#' @export
#'
.StoppingMissingDose <- setClass(
  Class = "StoppingMissingDose",
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingMissingDose-class
#' @param report_label (`string` or `NA`)\cr see slot definition.
#' @example examples/Rules-class-StoppingMissingDose.R
#' @export
#'
StoppingMissingDose <- function(report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("Stopped because of missing dose")
  )

  .StoppingMissingDose(report_label = report_label)
}

## default constructor ----

#' @rdname StoppingMissingDose-class
#' @note Typically, end users will not use the `.DefaultStoppingMissingDose()` function.
#' @export
#'
.DefaultStoppingMissingDose <- function() {
  StoppingMissingDose()
}

# StoppingCohortsNearDose ----

## class ----

#' `StoppingCohortsNearDose`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingCohortsNearDose`] is the class for stopping based on number of
#' cohorts near to next best dose.
#'
#'
#' @slot nCohorts (`number`)\cr number of required cohorts.
#' @slot percentage (`number`)\cr percentage (between and including 0 and 100)
#'   within the next best dose the cohorts must lie.
#'
#' @aliases StoppingCohortsNearDose
#' @export
#'
.StoppingCohortsNearDose <- setClass(
  Class = "StoppingCohortsNearDose",
  slots = c(
    nCohorts = "integer",
    percentage = "numeric"
  ),
  prototype = prototype(
    nCohorts = 2L,
    percentage = 50
  ),
  contains = "Stopping",
  validity = v_stopping_cohorts_near_dose
)

## constructor ----

#' @rdname StoppingCohortsNearDose-class
#'
#' @param nCohorts (`number`)\cr see slot definition.
#' @param percentage (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingCohortsNearDose.R
#' @export
#'
StoppingCohortsNearDose <- function(
  nCohorts = 2L,
  percentage = 50,
  report_label = NA_character_
) {
  assert_count(nCohorts, positive = TRUE)
  assert_numeric(percentage, lower = 0)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste(
      "\u2265",
      nCohorts,
      "cohorts dosed in",
      percentage,
      "% dose range around NBD"
    )
  )

  .StoppingCohortsNearDose(
    nCohorts = as.integer(nCohorts),
    percentage = percentage,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingCohortsNearDose-class
#' @note Typically, end users will not use the `.DefaultStoppingCohortsNearDose()` function.
#' @export
.DefaultStoppingCohortsNearDose <- function() {
  # nolint
  StoppingCohortsNearDose(
    nCohorts = 3L,
    percentage = 0.2
  )
}


# StoppingPatientsNearDose ----

## class ----

#' `StoppingPatientsNearDose`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingPatientsNearDose`] is the class for stopping based on number of
#' patients near to next best dose.
#'
#' @slot nPatients (`number`)\cr number of required patients.
#' @slot percentage (`number`)\cr percentage (between and including 0 and 100)
#'   within the next best dose the patients must lie.
#'
#' @aliases StoppingPatientsNearDose
#' @export
#'
.StoppingPatientsNearDose <- setClass(
  Class = "StoppingPatientsNearDose",
  slots = c(
    nPatients = "integer",
    percentage = "numeric"
  ),
  prototype = prototype(
    nPatients = 10L,
    percentage = 50
  ),
  contains = "Stopping",
  validity = v_stopping_patients_near_dose
)

## constructor ----

#' @rdname StoppingPatientsNearDose-class
#'
#' @param nPatients (`number`)\cr see slot definition.
#' @param percentage (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingPatientsNearDose.R
#' @export
#'
StoppingPatientsNearDose <- function(
  nPatients = 10L,
  percentage = 50,
  report_label = NA_character_
) {
  assert_count(nPatients, positive = TRUE)
  assert_number(percentage, lower = 0, upper = 100)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste(
      "\u2265",
      nPatients,
      "patients dosed in",
      percentage,
      "% dose range around NBD"
    )
  )

  .StoppingPatientsNearDose(
    nPatients = as.integer(nPatients),
    percentage = percentage,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingPatientsNearDose-class
#' @note Typically, end users will not use the `.DefaultStoppingPatientsNearDose()` function.
#' @export
.DefaultStoppingPatientsNearDose <- function() {
  # nolint
  StoppingPatientsNearDose(
    nPatients = 9L,
    percentage = 20,
    report_label = NA_character_
  )
}

# StoppingMinCohorts ----

## class ----

#' `StoppingMinCohorts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMinCohorts`] is the class for stopping based on minimum number of
#' cohorts.
#'
#' @slot nCohorts (`number`)\cr minimum required number of cohorts.
#'
#' @aliases StoppingMinCohorts
#' @export
#'
.StoppingMinCohorts <- setClass(
  Class = "StoppingMinCohorts",
  slots = c(nCohorts = "integer"),
  prototype = prototype(nCohorts = 2L),
  contains = "Stopping",
  validity = v_stopping_min_cohorts
)

## constructor ----

#' @rdname StoppingMinCohorts-class
#'
#' @param nCohorts (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingMinCohorts.R
#' @export
#'
StoppingMinCohorts <- function(nCohorts = 2L, report_label = NA_character_) {
  assert_count(nCohorts, positive = TRUE)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("\u2265", nCohorts, "cohorts dosed")
  )

  .StoppingMinCohorts(
    nCohorts = as.integer(nCohorts),
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMinCohorts-class
#' @note Typically, end users will not use the `.DefaultStoppingMinCohorts()` function.
#' @export
.DefaultStoppingMinCohorts <- function() {
  StoppingMinCohorts(
    nCohorts = 6L
  )
}

# StoppingMinPatients ----

## class ----

#' `StoppingMinPatients`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMinPatients`] is the class for stopping based on minimum number of
#' patients
#'
#' @slot nPatients (`number`)\cr minimum allowed number of patients.
#'
#' @aliases StoppingMinPatients
#' @export
#'
.StoppingMinPatients <- setClass(
  Class = "StoppingMinPatients",
  slots = c(nPatients = "integer"),
  prototype = prototype(nPatients = 20L),
  contains = "Stopping",
  validity = v_stopping_min_patients
)

## constructor ----

#' @rdname StoppingMinPatients-class
#'
#' @param nPatients (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingMinPatients.R
#' @export
#'
StoppingMinPatients <- function(nPatients = 20L, report_label = NA_character_) {
  assert_count(nPatients, positive = TRUE)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("\u2265", nPatients, "patients dosed")
  )

  .StoppingMinPatients(
    nPatients = as.integer(nPatients),
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMinPatients-class
#' @note Typically, end users will not use the `.DefaultStoppingMinPatients()` function.
#' @export
.DefaultStoppingMinPatients <- function() {
  StoppingMinPatients(
    nPatients = 20L
  )
}

# StoppingTargetProb ----

## class ----

#' `StoppingTargetProb`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingTargetProb`] is the class for stopping based on the probability of
#' the DLT rate being in the target toxicity interval.
#'
#' @slot target (`number`)\cr the target toxicity interval, e.g. `c(0.2, 0.35)`.
#' @slot prob (`proportion`)\cr required target toxicity probability (except 0 or 1)
#'   for reaching sufficient precision.
#'
#' @aliases StoppingTargetProb
#' @export
#'
.StoppingTargetProb <- setClass(
  Class = "StoppingTargetProb",
  slots = c(
    target = "numeric",
    prob = "numeric"
  ),
  prototype = prototype(
    target = c(0.2, 0.35),
    prob = 0.4
  ),
  contains = "Stopping",
  validity = v_stopping_target_prob
)

## constructor ----

#' @rdname StoppingTargetProb-class
#'
#' @param target (`number`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingTargetProb.R
#' @export
#'
StoppingTargetProb <- function(
  target = c(0.2, 0.35),
  prob = 0.4,
  report_label = NA_character_
) {
  assert_numeric(target, len = 2)
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0(
      "P(",
      target[1],
      " \u2264 prob(DLE | NBD) \u2264 ",
      target[2],
      ") \u2265 ",
      prob
    )
  )

  .StoppingTargetProb(
    target = target,
    prob = prob,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingTargetProb-class
#' @note Typically, end users will not use the `.DefaultStoppingTargetProb()` function.
#' @export
.DefaultStoppingTargetProb <- function() {
  StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
}

# StoppingMTDdistribution ----

## class ----

#' `StoppingMTDdistribution`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMTDdistribution`] is the class for stopping based on the posterior
#' distribution of the MTD. It is used for the cases where the stopping occurs
#' when the probability of `MTD > thresh * next_dose` is greater than or equal
#' to `prob`, where the `next_dose` is the recommended next best dose.
#' Here, the MTD is defined as the dose that reaches a specific `target`
#' probability of the occurrence of a DLT.
#'
#' @slot target (`proportion`)\cr the target toxicity probability (except 0 or 1)
#'   defining the MTD.
#' @slot thresh (`proportion`)\cr the threshold (except 0 or 1) relative to the
#'   recommended next best dose.
#' @slot prob (`proportion`)\cr required minimum probability, except 0 or 1.
#'
#' @aliases StoppingMTDdistribution
#' @export
#'
.StoppingMTDdistribution <- setClass(
  Class = "StoppingMTDdistribution",
  slots = c(
    target = "numeric",
    thresh = "numeric",
    prob = "numeric"
  ),
  prototype = prototype(
    target = 0.33,
    thresh = 0.5,
    prob = 0.9
  ),
  contains = "Stopping",
  validity = v_stopping_mtd_distribution
)

## constructor ----

#' @rdname StoppingMTDdistribution-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param thresh (`proportion`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingMTDdistribution.R
#' @export
#'
StoppingMTDdistribution <- function(
  target = 0.33,
  thresh = 0.5,
  prob = 0.9,
  report_label = NA_character_
) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0("P(MTD > ", thresh, " * NBD | P(DLE) = ", target, ") \u2265 ", prob)
  )

  .StoppingMTDdistribution(
    target = target,
    thresh = thresh,
    prob = prob,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMTDdistribution-class
#' @note Typically, end users will not use the `.DefaultStoppingMTDDistribution()` function.
#' @export
.DefaultStoppingMTDdistribution <- function() {
  StoppingMTDdistribution(
    target = 0.33,
    thresh = 0.5,
    prob = 0.9
  )
}

# StoppingMTDCV ----

## class ----

#' `StoppingMTDCV`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingMTDCV`] is a class for stopping rule based on precision of MTD
#' which is calculated as the coefficient of variation (CV) of the MTD.
#' Here, the MTD is defined as the dose that reaches a specific `target`
#' probability of the occurrence of a DLT.
#'
#' @slot target (`proportion`)\cr toxicity target of MTD (except 0 or 1).
#' @slot thresh_cv (`number`)\cr threshold (percentage > 0) for CV to be
#'   considered accurate enough to stop the trial. The stopping occurs when the
#'   CV is less than or equal to `tresh_cv`.
#'
#' @aliases StoppingMTDCV
#' @export
#'
.StoppingMTDCV <- setClass(
  Class = "StoppingMTDCV",
  slots = c(
    target = "numeric",
    thresh_cv = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    thresh_cv = 40
  ),
  contains = "Stopping",
  validity = v_stopping_mtd_cv
)

## constructor ----

#' @rdname StoppingMTDCV-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param thresh_cv (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingMTDCV.R
#'
StoppingMTDCV <- function(
  target = 0.3,
  thresh_cv = 40,
  report_label = NA_character_
) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("CV(MTD) >", target)
  )

  .StoppingMTDCV(
    target = target,
    thresh_cv = thresh_cv,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMTDCV-class
#' @note Typically, end users will not use the `.DefaultStoppingMTDCV()` function.
#'
#' @export
.DefaultStoppingMTDCV <- function() {
  StoppingMTDCV(
    target = 0.3,
    thresh_cv = 40
  )
}

# StoppingLowestDoseHSRBeta ----

## class ----

#' `StoppingLowestDoseHSRBeta`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingLowestDoseHSRBeta`] is a class for stopping based on a Hard Safety
#' Rule using the Beta posterior distribution with Beta(a,b) prior and a
#' Bin-Beta model based on the observed data at the lowest dose level.
#' The rule is triggered when the first dose is considered to be toxic
#' (i.e. above threshold probability) based on the observed data at the
#' lowest dose level and a Beta(a,b) prior distribution.
#' The default prior is Beta(1,1).
#' In case that placebo is used, the rule is evaluated at the second dose of the
#' dose grid, i.e. at the lowest non-placebo dose.
#'
#' @note This stopping rule is independent from the underlying model.
#'
#' @slot target (`proportion`)\cr the target toxicity.
#' @slot prob (`proportion`)\cr the threshold probability for the lowest dose
#'   being toxic.
#' @slot a (`number`)\cr shape parameter \eqn{a > 0} of probability distribution
#'   Beta (a,b).
#' @slot b (`number`)\cr shape parameter \eqn{b > 0} of probability distribution
#'   Beta (a,b).
#'
#' @aliases StoppingLowestDoseHSRBeta
#' @export
#'
.StoppingLowestDoseHSRBeta <- setClass(
  Class = "StoppingLowestDoseHSRBeta",
  slots = c(
    target = "numeric",
    prob = "numeric",
    a = "numeric",
    b = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    prob = 0.95,
    a = 1,
    b = 1
  ),
  contains = "Stopping",
  validity = v_increments_hsr_beta
)

## constructor ----

#' @rdname StoppingLowestDoseHSRBeta-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param a (`number`)\cr see slot definition.
#' @param b (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingLowestDoseHSRBeta.R
#'
StoppingLowestDoseHSRBeta <- function(
  target = 0.3,
  prob = 0.95,
  a = 1,
  b = 1,
  report_label = NA_character_
) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0("P\u03B2(lowest dose > P(DLE) = ", target, ") > ", prob)
  )

  .StoppingLowestDoseHSRBeta(
    target = target,
    prob = prob,
    a = a,
    b = b,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingLowestDoseHSRBeta-class
#' @note Typically, end users will not use the `.DefaultStoppingLowestDoseHSRBeta()` function.
#' @export
.DefaultStoppingLowestDoseHSRBeta <- function() {
  # nolint
  StoppingLowestDoseHSRBeta(
    target = 0.3,
    prob = 0.95,
    a = 1,
    b = 1
  )
}

# StoppingTargetBiomarker ----

## class ----

#' `StoppingTargetBiomarker`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingTargetBiomarker`] is a class for stopping based on probability of
#' target biomarker.
#'
#' @slot target (`numeric`)\cr the biomarker target range that needs to be
#'   reached. For example, `target = c(0.8, 1.0)` with `is_relative = TRUE`
#'   means that we target a dose with at least 80% of maximum biomarker level.
#' @slot is_relative (`flag`)\cr is target relative? If it so (default), then
#'   the `target` is interpreted relative to the maximum, so it must be a
#'   probability range. Otherwise, the `target` is interpreted as absolute
#'   biomarker range.
#' @slot prob (`proportion`)\cr required target probability (except 0 or 1) for
#'   reaching sufficient precision.
#'
#' @aliases StoppingTargetBiomarker
#' @export
#'
.StoppingTargetBiomarker <- setClass(
  Class = "StoppingTargetBiomarker",
  slots = c(
    target = "numeric",
    is_relative = "logical",
    prob = "numeric"
  ),
  prototype = prototype(
    target = c(0.9, 1),
    is_relative = TRUE,
    prob = 0.3
  ),
  contains = "Stopping",
  validity = v_stopping_target_biomarker
)

## constructor ----

#' @rdname StoppingTargetBiomarker-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param is_relative (`flag`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingTargetBiomarker.R
#'
StoppingTargetBiomarker <- function(
  target = c(0.9, 1),
  prob = 0.3,
  is_relative = TRUE,
  report_label = NA_character_
) {
  assert_numeric(target, len = 2)
  assert_flag(is_relative)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0(
      "P(",
      target[1],
      " \u2264 ",
      "Biomarker \u2264 ",
      target[2],
      ") \u2265 ",
      prob,
      ifelse(is_relative, " (relative)", " (absolute)")
    )
  )

  .StoppingTargetBiomarker(
    target = target,
    is_relative = is_relative,
    prob = prob,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingTargetBiomarker-class
#' @note Typically, end users will not use the `.DefaultStoppingTargetBiomarker()` function.
#' @export
.DefaultStoppingTargetBiomarker <- function() {
  StoppingTargetBiomarker(
    target = c(0.9, 1),
    prob = 0.5,
    is_relative = TRUE
  )
}

# StoppingSpecificDose ----

## class ----

#' `StoppingSpecificDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingSpecificDose`] is the class for testing a stopping rule at specific
#' dose of the dose grid and not at the next best dose.
#'
#' @slot rule (`Stopping`)\cr a stopping rule available in this package.
#' @slot dose (`positive_number`)\cr a dose that is defined as part of the dose
#'   grid of the data.
#'
#' @aliases StoppingSpecificDose
#' @export
#'
.StoppingSpecificDose <- setClass(
  Class = "StoppingSpecificDose",
  slots = c(
    rule = "Stopping",
    dose = "positive_number"
  ),
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingSpecificDose-class
#'
#' @param rule (`Stopping`)\cr see slot definition.
#' @param dose (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`) \cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingSpecificDose.R
#'
StoppingSpecificDose <- function(
  rule = StoppingTargetProb(target = c(0, 0.3), prob = 0.8),
  dose = 80,
  report_label = NA_character_
) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0("Dose ", dose, " used for testing a stopping rule")
  )

  .StoppingSpecificDose(
    rule = rule,
    dose = positive_number(dose),
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingSpecificDose-class
#' @note Typically, end users will not use the `.DefaultStoppingSpecificDose()` function.
#' @export
.DefaultStoppingSpecificDose <- function() {
  StoppingSpecificDose(
    rule = StoppingTargetProb(target = c(0, 0.3), prob = 0.8),
    dose = positive_number(80)
  )
}

# StoppingHighestDose ----

## class ----

#' `StoppingHighestDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingHighestDose`] is the class for stopping based on the highest dose.
#' That is, the stopping occurs when the highest dose is reached.
#'
#' @aliases StoppingHighestDose
#' @export
#'
.StoppingHighestDose <- setClass(
  Class = "StoppingHighestDose",
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingHighestDose-class
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingHighestDose.R
#'
StoppingHighestDose <- function(report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    "NBD is the highest dose"
  )

  .StoppingHighestDose(report_label = report_label)
}

## default constructor ----

#' @rdname StoppingHighestDose-class
#' @note Typically, end users will not use the `.DefaultStoppingHighestDose()` function.
#' @export
.DefaultStoppingHighestDose <- function() {
  StoppingHighestDose()
}

# StoppingTDCIRatio ----

## class ----

#' `StoppingTDCIRatio`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingTDCIRatio`] is the class for testing a stopping rule that is based
#' on a target ratio of the 95% credibility interval. Specifically, this is the
#' ratio of the upper to the lower bound of the 95% credibility interval's
#' estimate of the target dose (i.e. a dose that corresponds to a given target
#' probability of the occurrence of a DLT `prob_target`).
#'
#' @slot target_ratio (`numeric`)\cr target for the ratio of the 95% credibility
#'   interval's estimate, that is required to stop a trial.
#' @slot prob_target (`proportion`)\cr the target probability of the occurrence
#'   of a DLT.
#'
#' @aliases StoppingTDCIRatio
#' @export
#'
.StoppingTDCIRatio <- setClass(
  Class = "StoppingTDCIRatio",
  slots = c(
    target_ratio = "numeric",
    prob_target = "numeric"
  ),
  prototype = prototype(
    target_ratio = 5,
    prob_target = 0.3
  ),
  contains = "Stopping",
  validity = v_stopping_tdci_ratio
)

## constructor ----

#' @rdname StoppingTDCIRatio-class
#'
#' @param target_ratio (`numeric`)\cr see slot definition.
#' @param prob_target (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingTDCIRatio.R
#'
StoppingTDCIRatio <- function(
  target_ratio = 5,
  prob_target = 0.3,
  report_label = NA_character_
) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("TD", target_ratio, "for", prob_target, "target prob")
  )

  .StoppingTDCIRatio(
    target_ratio = target_ratio,
    prob_target = prob_target,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingTDCIRatio-class
#' @note Typically, end users will not use the `.DefaultStoppingTDCIRatio()` function.
#' @export
.DefaultStoppingTDCIRatio <- function() {
  StoppingTDCIRatio(
    target_ratio = 5,
    prob_target = 0.3
  )
}

# StoppingMaxGainCIRatio ----

## class ----

#' `StoppingMaxGainCIRatio`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMaxGainCIRatio`] is the class for testing a stopping rule that is based
#' on a target ratio of the 95% credibility interval. Specifically, this is the
#' ratio of the upper to the lower bound of the 95% credibility interval's
#' estimate of the:
#' (1) target dose (i.e. a dose that corresponds to a given target
#' probability of the occurrence of a DLT `prob_target`), or
#' (2) max gain dose (i.e. a dose which gives the maximum gain),
#' depending on which one out of these two is smaller.
#'
#' @slot target_ratio (`numeric`)\cr target for the ratio of the 95% credibility
#'   interval's estimate, that is required to stop a trial.
#' @slot prob_target (`proportion`)\cr the target probability of the occurrence
#'   of a DLT.
#'
#' @aliases StoppingMaxGainCIRatio
#' @export
#'
.StoppingMaxGainCIRatio <- setClass(
  Class = "StoppingMaxGainCIRatio",
  slots = c(
    target_ratio = "numeric",
    prob_target = "numeric"
  ),
  prototype = prototype(
    target_ratio = 5,
    prob_target = 0.3
  ),
  contains = "Stopping",
  validity = v_stopping_tdci_ratio
)

## constructor ----

#' @rdname StoppingMaxGainCIRatio-class
#'
#' @param target_ratio (`numeric`)\cr see slot definition.
#' @param prob_target (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingMaxGainCIRatio.R
#'
StoppingMaxGainCIRatio <- function(
  target_ratio = 5,
  prob_target = 0.3,
  report_label = NA_character_
) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("GStar", target_ratio, "for", prob_target, "target prob")
  )

  .StoppingMaxGainCIRatio(
    target_ratio = target_ratio,
    prob_target = prob_target,
    report_label = report_label
  )
}


## default constructor ----

#' @rdname StoppingMaxGainCIRatio-class
#' @examples
#' .DefaultStoppingMaxGainCIRatio()
#' @export
.DefaultStoppingMaxGainCIRatio <- function() {
  StoppingMaxGainCIRatio(
    target_ratio = 5,
    prob_target = 0.3
  )
}

# StoppingList ----

## class ----

#' `StoppingList`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingList`] is the class for testing a stopping rule that consists of
#' many single stopping rules that are in turn the objects of class `Stopping`.
#' The `summary` slot stores a function that takes a logical vector of the size
#' of `stop_list` and returns a single logical value. For example, if the function
#' `all` is specified as a `summary` function, then that all stopping rules
#' defined in `stop_list` must be satisfied in order the result of this rule to
#' be `TRUE`.
#'
#' @slot stop_list (`list`)\cr list of stopping rules.
#' @slot summary (`function`)\cr a summary function to combine the results of
#'   the stopping rules into a single result.
#'
#' @aliases StoppingList
#' @export
#'
.StoppingList <- setClass(
  Class = "StoppingList",
  slots = c(
    stop_list = "list",
    summary = "function"
  ),
  prototype = prototype(
    stop_list = list(StoppingMinPatients(50), StoppingMinCohorts(5)),
    summary = all
  ),
  contains = "Stopping",
  validity = v_stopping_list
)

## constructor ----

#' @rdname StoppingList-class
#'
#' @param stop_list (`list`)\cr see slot definition.
#' @param summary (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingList.R
#'
StoppingList <- function(stop_list, summary) {
  .StoppingList(
    stop_list = stop_list,
    summary = summary
  )
}

## default constructor ----

#' @rdname StoppingList-class
#' @note Typically, end users will not use the `.DefaultStoppingList()` function.
#' @export
.DefaultStoppingList <- function() {
  StoppingList(
    stop_list = c(
      StoppingMinCohorts(nCohorts = 3L),
      StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5),
      StoppingMinPatients(nPatients = 20L)
    ),
    summary = any
  )
}

# StoppingAll ----

## class ----

#' `StoppingAll`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingAll`] is the class for testing a stopping rule that consists of
#' many single stopping rules that are in turn the objects of class `Stopping`.
#' All single stopping rules must be satisfied in order the result of this rule
#' to be `TRUE`.
#'
#' @slot stop_list (`list`)\cr list of stopping rules.
#' @slot report_label label for reporting
#' @aliases StoppingAll
#' @export
#'
.StoppingAll <- setClass(
  Class = "StoppingAll",
  slots = c(
    stop_list = "list"
  ),
  prototype = prototype(
    stop_list = list(
      StoppingMinPatients(50),
      StoppingMinCohorts(5)
    )
  ),
  contains = "Stopping",
  validity = v_stopping_all
)

## constructor ----

#' @rdname StoppingAll-class
#'
#' @param stop_list (`list`)\cr see slot definition.
#' @param report_label (`string`) \cr see slot definition.
#' @export
#' @example examples/Rules-class-StoppingAll.R
#'
StoppingAll <- function(stop_list, report_label = NA_character_) {
  .StoppingAll(
    stop_list = stop_list,
    report_label = report_label
  )
}
## default constructor ----

#' @rdname StoppingAll-class
#' @note Typically, end users will not use the `.DefaultStoppingAll()` function.
#' @export
.DefaultStoppingAll <- function() {
  StoppingAll(
    stop_list = c(
      StoppingMinCohorts(nCohorts = 3L),
      StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5),
      StoppingMinPatients(nPatients = 20L)
    )
  )
}

# StoppingAny ----

## class ----

#' `StoppingAny`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingAny`] is the class for testing a stopping rule that consists of
#' many single stopping rules that are in turn the objects of class `Stopping`.
#' At least one single stopping rule must be satisfied in order the result of
#' this rule to be `TRUE`.
#'
#' @slot stop_list (`list`)\cr list of stopping rules.
#' @slot report_label label for reporting
#'
#' @aliases StoppingAny
#' @export
#'
.StoppingAny <- setClass(
  Class = "StoppingAny",
  slots = c(
    stop_list = "list"
  ),
  prototype = prototype(
    stop_list = list(StoppingMinPatients(50), StoppingMinCohorts(5))
  ),
  contains = "Stopping",
  validity = v_stopping_all
)

## constructor ----

#' @rdname StoppingAny-class
#'
#' @param stop_list (`list`)\cr see slot definition.
#' @param report_label (`string`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingAny.R
#'
StoppingAny <- function(stop_list, report_label = NA_character_) {
  .StoppingAny(
    stop_list = stop_list,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingAny-class
#' @note Typically, end users will not use the `.DefaultStoppingAny()` function.
#' @export
.DefaultStoppingAny <- function() {
  StoppingAny(
    stop_list = c(
      StoppingMinCohorts(nCohorts = 3L),
      StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5),
      StoppingMinPatients(nPatients = 20L)
    )
  )
}

# StoppingOrdinal ----

## class ----

#' `StoppingOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingOrdinal`] is the class for stopping based on a Stopping rule applied
#' to a specific toxicity grade in an ordinal CRM trial
#'
#' @slot grade (`integer`)\cr the grade to which the rule should be applied
#' @slot rule (`Stopping`)\cr the rule to apply
#'
#' @aliases StoppingOrdinal
#' @export
#'
.StoppingOrdinal <- setClass(
  Class = "StoppingOrdinal",
  slots = c(grade = "integer", rule = "Stopping"),
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingOrdinal-class
#' @param grade (`integer`)\cr see slot definition.
#' @param rule (`Stopping`)\cr see slot definition.
#' @example examples/Rules-class-StoppingOrdinal.R
#' @export
#'
StoppingOrdinal <- function(grade, rule) {
  .StoppingOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname StoppingOrdinal-class
#' @note Typically, end users will not use the `.DefaultStoppingOrdinal()` function.
#' @export
#'
.DefaultStoppingOrdinal <- function() {
  StoppingOrdinal(
    1L,
    StoppingTargetProb(target = c(0.2, 0.35), prob = 0.6)
  )
}

# StoppingExternal ----

## class ----

#' `StoppingExternal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingExternal`] is the class for stopping based on an external flag.
#'
#' @aliases StoppingExternal
#' @export
#'
.StoppingExternal <- setClass(
  Class = "StoppingExternal",
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingExternal-class
#' @param report_label (`string` or `NA`)\cr see slot definition.
#' @example examples/Rules-class-StoppingExternal.R
#' @export
#'
StoppingExternal <- function(report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("Stopped because of external flag")
  )
  .StoppingExternal(report_label = report_label)
}

## default constructor ----

#' @rdname StoppingExternal-class
#' @note Typically, end users will not use the `.DefaultStoppingExternal()` function.
#' @export
#'
.DefaultStoppingExternal <- StoppingExternal

# CohortSize ----

## class ----

#' `CohortSize`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSize`] is a class for cohort sizes.
#'
#' @seealso [`CohortSizeRange`], [`CohortSizeDLT`], [`CohortSizeConst`],
#'   [`CohortSizeParts`], [`CohortSizeMin`], [`CohortSizeMin`].
#'
#' @aliases CohortSize
#' @export
#'
setClass(
  Class = "CohortSize",
  contains = "CrmPackClass"
)

## default constructor

#' @rdname CohortSize-class
#' @note Typically, end users will not use the `DefaultCohortSize()` function.
#' @export
.DefaultCohortSize <- function() {
  stop(paste0(
    "Class CohortSize should not be instantiated directly.  Please use one of its subclasses instead."
  ))
}

# CohortSizeRange ----

## class ----

#' `CohortSizeRange`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeRange`] is the class for cohort size based on dose range.
#'
#' @slot intervals (`numeric`)\cr a vector with the left bounds of the relevant
#'   dose intervals.
#' @slot cohort_size (`integer`)\cr an integer vector with the cohort sizes
#'   corresponding to the elements of `intervals`.
#'
#' @aliases CohortSizeRange
#' @export
#'
.CohortSizeRange <- setClass(
  Class = "CohortSizeRange",
  slots = c(
    intervals = "numeric",
    cohort_size = "integer"
  ),
  prototype = prototype(
    intervals = c(0, 20),
    cohort_size = c(1L, 3L)
  ),
  contains = "CohortSize",
  validity = v_cohort_size_range
)

## constructor ----

#' @rdname CohortSizeRange-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param cohort_size (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeRange.R
#'
CohortSizeRange <- function(intervals, cohort_size) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(cohort_size, lower = 0, any.missing = FALSE)

  .CohortSizeRange(
    intervals = intervals,
    cohort_size = as.integer(cohort_size)
  )
}

## default constructor ----

#' @rdname CohortSizeRange-class
#' @note Typically, end users will not use the `.DefaultCohortSizeRange()` function.
#' @export
.DefaultCohortSizeRange <- function() {
  CohortSizeRange(intervals = c(0L, 30L), cohort_size = c(1L, 3L))
}

# CohortSizeDLT ----

## class ----

#' `CohortSizeDLT`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeDLT`] is the class for cohort size based on number of DLTs.

#' @slot intervals (`integer`)\cr a vector with the left bounds of the
#'   relevant DLT intervals.
#' @slot cohort_size (`integer`)\cr a vector with the cohort sizes corresponding
#'   to the elements of `intervals`.
#'
#' @aliases CohortSizeDLT
#' @export
#'
.CohortSizeDLT <- setClass(
  Class = "CohortSizeDLT",
  slots = c(
    intervals = "integer",
    cohort_size = "integer"
  ),
  prototype = prototype(
    intervals = c(0L, 1L),
    cohort_size = c(1L, 3L)
  ),
  contains = "CohortSize",
  validity = v_cohort_size_dlt
)

## constructor ----

#' @rdname CohortSizeDLT-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param cohort_size (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeDLT.R
#'
CohortSizeDLT <- function(intervals, cohort_size) {
  assert_integerish(intervals, lower = 0, any.missing = FALSE)
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(cohort_size, lower = 0, any.missing = FALSE)

  .CohortSizeDLT(
    intervals = as.integer(intervals),
    cohort_size = as.integer(cohort_size)
  )
}

## default constructor ----

#' @rdname CohortSizeDLT-class
#' @note Typically, end users will not use the `.DefaultCohortSizeDLT()` function.
#' @export
.DefaultCohortSizeDLT <- function() {
  CohortSizeDLT(intervals = c(0L, 1L), cohort_size = c(1L, 3L))
}


# CohortSizeConst ----

## class ----

#' `CohortSizeConst`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeConst`] is the class for fixed and constant size of cohort.
#'
#' @slot size (`integer`)\cr cohort size.
#'
#' @aliases CohortSizeConst
#' @export
#'
.CohortSizeConst <- setClass(
  Class = "CohortSizeConst",
  slots = c(size = "integer"),
  prototype = prototype(size = 3L),
  contains = "CohortSize",
  validity = v_cohort_size_const
)

## constructor ----

#' @rdname CohortSizeConst-class
#'
#' @param size (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeConst.R
#'
CohortSizeConst <- function(size) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(size, lower = 0)
  .CohortSizeConst(size = as.integer(size))
}

## default constructor ----

#' @rdname CohortSizeConst-class
#' @note Typically, end users will not use the `.DefaultCohortSizeConst()` function.
#' @export
.DefaultCohortSizeConst <- function() {
  CohortSizeConst(size = 3L)
}

# CohortSizeParts ----

## class ----

#' `CohortSizeParts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeParts`] is the class for cohort size that changes for the second
#' part of the dose escalation. It works only in conjunction with [`DataParts`]
#' objects.
#'
#' @slot cohort_sizes (`integer`)\cr a vector of length two with two sizes, one for
#'   part 1, and one for part 2 respectively.
#'
#' @aliases CohortSizeParts
#' @export
#'
.CohortSizeParts <- setClass(
  Class = "CohortSizeParts",
  slots = c(cohort_sizes = "integer"),
  prototype = prototype(cohort_sizes = c(1L, 3L)),
  contains = "CohortSize",
  validity = v_cohort_size_parts
)

## constructor ----

#' @rdname CohortSizeParts-class
#'
#' @param cohort_sizes (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeParts.R
#'
CohortSizeParts <- function(cohort_sizes) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(cohort_sizes, lower = 0, any.missing = FALSE)
  .CohortSizeParts(cohort_sizes = as.integer(cohort_sizes))
}

## default constructor ----

#' @rdname CohortSizeParts-class
#' @note Typically, end users will not use the `.DefaultCohortSizeParts()` function.
#' @export
.DefaultCohortSizeParts <- function() {
  CohortSizeParts(cohort_sizes = c(1L, 3L))
}

# CohortSizeMax ----

## class ----

#' `CohortSizeMax`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeMax`] is the class for cohort size that is based on maximum of
#' multiple cohort size rules. The `cohort_sizes` slot stores a set of cohort
#' size rules, which are again the objects of class [`CohortSize`]. The maximum
#' of these individual cohort sizes is taken to give the final cohort size.
#'
#' @slot cohort_sizes (`list`)\cr a list of cohort size rules, i.e. objects
#' of class [`CohortSize`].
#'
#' @aliases CohortSizeMax
#' @export
#'
.CohortSizeMax <- setClass(
  Class = "CohortSizeMax",
  slots = c(cohort_sizes = "list"),
  prototype = prototype(
    cohort_sizes = list(
      CohortSizeRange(intervals = c(0, 30), cohort_size = c(1, 3)),
      CohortSizeDLT(intervals = c(0, 1), cohort_size = c(1, 3))
    )
  ),
  contains = "CohortSize",
  validity = v_cohort_size_max
)

## default constructor ----

#' @rdname CohortSizeMax-class
#' @note Typically, end users will not use the `.DefaultCohortSizeMax()` function.
#'
#' @export
.DefaultCohortSizeMax <- function() {
  CohortSizeMax(
    cohort_sizes = list(
      CohortSizeRange(intervals = c(0, 10), cohort_size = c(1L, 3L)),
      CohortSizeDLT(intervals = c(0L, 1L), cohort_size = c(1L, 3L))
    )
  )
}

## constructor ----

#' @rdname CohortSizeMax-class
#'
#' @param cohort_sizes (`list`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeMax.R
#'
CohortSizeMax <- function(cohort_sizes) {
  .CohortSizeMax(cohort_sizes = cohort_sizes)
}

# CohortSizeMin ----

## class ----

#' `CohortSizeMin`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeMin`] is the class for cohort size that is based on minimum of
#' multiple cohort size rules. The `cohort_sizes` slot stores a set of cohort
#' size rules, which are again the objects of class [`CohortSize`]. The minimum
#' of these individual cohort sizes is taken to give the final cohort size.
#'
#' @slot cohort_sizes (`list`)\cr a list of cohort size rules, i.e. objects
#' of class [`CohortSize`].
#'
#' @aliases CohortSizeMin
#' @export
#'
.CohortSizeMin <- setClass(
  Class = "CohortSizeMin",
  slots = c(cohort_sizes = "list"),
  prototype = prototype(
    cohort_sizes = list(
      CohortSizeRange(intervals = c(0, 30), cohort_size = c(1, 3)),
      CohortSizeDLT(intervals = c(0, 1), cohort_size = c(1, 3))
    )
  ),
  contains = "CohortSize",
  validity = v_cohort_size_max
)

## constructor ----

#' @rdname CohortSizeMin-class
#'
#' @param cohort_sizes (`list`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeMin.R
#'
CohortSizeMin <- function(cohort_sizes) {
  .CohortSizeMin(cohort_sizes = cohort_sizes)
}

## default constructor ----

#' @rdname CohortSizeMin-class
#' @note Typically, end users will not use the `.DefaultCohortSizeMin()` function.
#' @export
.DefaultCohortSizeMin <- function() {
  CohortSizeMin(
    cohort_sizes = list(
      CohortSizeRange(intervals = c(0, 10), cohort_size = c(1L, 3L)),
      CohortSizeDLT(intervals = c(0L, 1L), cohort_size = c(1L, 3L))
    )
  )
}

# CohortSizeOrdinal ----

## class ----

#' `CohortSizeOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`CohortSizeOrdinal`] is the class for cohort size for an ordinal CRM trial.
#'
#' @slot grade (`integer`)\cr the grade at which the rule should be applied
#' @slot rule (`CohortSize`)\cr the `CohortSize` rule to apply.
#'
#' @aliases CohortSizeOrdinal
#' @export
#'
.CohortSizeOrdinal <- setClass(
  Class = "CohortSizeOrdinal",
  slots = c(
    grade = "integer",
    rule = "CohortSize"
  ),
  prototype = prototype(
    grade = 1L,
    rule = CohortSizeRange(intervals = c(0, 30), cohort_size = c(1L, 3L))
  ),
  contains = "CohortSize",
  validity = v_cohort_size_ordinal
)

## constructor ----

#' @rdname CohortSizeOrdinal-class
#'
#' @param grade (`integer`)\cr see slot definition.
#' @param rule (`CohortSize`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeOrdinal.R
#'
CohortSizeOrdinal <- function(grade, rule) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integer(grade, lower = 1, len = 1)
  assert_class(rule, "CohortSize")

  .CohortSizeOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname CohortSizeOrdinal-class
#' @note Typically, end users will not use the `.DefaultCohortSizeOrdinal()` function.
#' @export
.DefaultCohortSizeOrdinal <- function() {
  CohortSizeOrdinal(
    grade = 1L,
    rule = CohortSizeRange(intervals = c(0L, 30L), cohort_size = c(1L, 3L))
  )
}


# SafetyWindow ----

## class ----

#' `SafetyWindow`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`SafetyWindow`] is a class for safety window.
#'
#' @seealso [`SafetyWindowSize`], [`SafetyWindowConst`].
#'
#' @aliases SafetyWindow
#' @export
#'
setClass(
  Class = "SafetyWindow",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname SafetyWindow-class
#' @note Typically, end users will not use the `.DefaultSafetyWindow()` function.
#' @export
.DefaultSafetyWindow <- function() {
  stop(paste0(
    "Class SafetyWindow cannot be instantiated directly.  Please use one of its subclasses instead."
  ))
}


# SafetyWindowSize ----

## class ----

#' `SafetyWindowSize`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`SafetyWindowSize`] is the class for safety window length based on cohort
#' size. This class is used to decide the rolling rule from the clinical
#' perspective.
#'
#' @slot gap (`list`)\cr observed period of the previous patient before
#'   the next patient can be dosed. This is used as follows. If for instance,
#'   the cohort size is 4 and we want to specify three time intervals between
#'   these four consecutive patients, i.e. 7 units of time between the 1st and
#'   the 2nd patient, 5 units between the 2nd and the 3rd one, and finally 3
#'   units between the 3rd and the 4th one, then,
#'   `gap` = `list(c(7L, 5L, 3L))`. Sometimes, we want that the interval
#'   only between the 1st and 2nd patient should be increased for the
#'   safety consideration and the rest time intervals should remain constant,
#'   regardless of what the cohort size is. Then, `gap` = `list(c(7L, 3L))`
#'   and the the package will automatically repeat the last element of the vector
#'   for the remaining time intervals.
#' @slot size (`integer`)\cr a vector with the left bounds of the
#'   relevant cohort size intervals. This is used as follows. For instance, when
#'   we want to change the `gap` based on the cohort size, i.e. the time
#'   interval between the 1st and 2nd patient = 9 units of time and the rest
#'   time intervals are of 5 units of time when the cohort size is equal to or
#'   larger than 4. And the time interval between the 1st and 2nd patient = 7 units
#'   of time and the rest time intervals are 3 units of time when the cohort size
#'   is smaller than 4, then we specify both `gap = list(c(7, 3), c(9, 5))` and
#'   `size = c(0L, 4L)`. This means, the right bounds of the intervals are
#'   excluded from the interval, and the last interval goes from the last value
#'   to infinity.
#' @slot follow (`count`)\cr the period of time that each patient in the
#'   cohort needs to be followed before the next cohort opens.
#' @slot follow_min (`count`)\cr at least one patient in the cohort needs
#'   to be followed at the minimal follow up time.
#'
#' @aliases SafetyWindowSize
#' @export
#'
.SafetyWindowSize <- setClass(
  Class = "SafetyWindowSize",
  slots = c(
    gap = "list",
    size = "integer",
    follow = "integer",
    follow_min = "integer"
  ),
  prototype = prototype(
    gap = list(1:2, 1:2),
    size = c(1L, 3L),
    follow = 1L,
    follow_min = 1L
  ),
  contains = "SafetyWindow",
  validity = v_safety_window_size
)

## constructor ----

#' @rdname SafetyWindowSize-class
#'
#' @param gap see slot definition.
#' @param size see slot definition.
#' @param follow see slot definition.
#' @param follow_min see slot definition.
#'
#' @export
#' @example examples/Rules-class-SafetyWindowSize.R
#'
SafetyWindowSize <- function(gap, size, follow, follow_min) {
  assert_integerish(follow, lower = 0)
  assert_integerish(follow_min, lower = 0)
  for (g in gap) {
    assert_integerish(g, lower = 0)
  }
  assert_integerish(size, lower = 0)
  if (follow > follow_min) {
    warning(
      "The value of follow_min is typically larger than the value of follow"
    )
  }
  gap <- lapply(gap, as.integer)
  .SafetyWindowSize(
    gap = gap,
    size = as.integer(size),
    follow = as.integer(follow),
    follow_min = as.integer(follow_min)
  )
}

## default constructor ----

#' @rdname SafetyWindowSize-class
#' @note Typically, end users will not use the `.DefaultSafetyWindowSize()` function.
#' @export
.DefaultSafetyWindowSize <- function() {
  SafetyWindowSize(
    gap = list(c(7, 3), c(9, 5)),
    size = c(1, 4),
    follow = 7,
    follow_min = 14
  )
}

# SafetyWindowConst ----

## class ----

#' `SafetyWindowConst`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`SafetyWindowConst`] is the class for safety window length and it is used
#' when the `gap` should be kept constant across cohorts (though it may vary
#' within a cohort).
#'
#' @slot gap (`integer`)\cr a vector, the constant gap between patients.
#' @slot follow (`count`)\cr how long to follow each patient. The period of time
#'   that each patient in the cohort needs to be followed before the next cohort
#'   opens.
#' @slot follow_min (`count`)\cr minimum follow up. At least one patient in the
#'   cohort needs to be followed at the minimal follow up time.
#'
#' @aliases SafetyWindowConst
#' @export
#'
.SafetyWindowConst <- setClass(
  Class = "SafetyWindowConst",
  slots = c(
    gap = "integer",
    follow = "integer",
    follow_min = "integer"
  ),
  prototype = prototype(
    gap = 0L,
    follow = 1L,
    follow_min = 1L
  ),
  contains = "SafetyWindow",
  validity = v_safety_window_const
)

## constructor ----

#' @rdname SafetyWindowConst-class
#'
#' @param gap see slot definition.
#' @param follow see slot definition.
#' @param follow_min see slot definition.
#'
#' @export
#' @example examples/Rules-class-SafetyWindowConst.R
#'
SafetyWindowConst <- function(gap, follow, follow_min) {
  assert_integerish(follow, lower = 0)
  assert_integerish(follow_min, lower = 0)
  assert_integerish(gap, lower = 0)

  if (follow > follow_min) {
    warning(
      "The value of follow_min is typically larger than the value of follow"
    )
  }
  .SafetyWindowConst(
    gap = as.integer(gap),
    follow = as.integer(follow),
    follow_min = as.integer(follow_min)
  )
}

## default constructor ----

#' @rdname SafetyWindowConst-class
#' @note Typically, end users will not use the `.DefaultSafetyWindowConst()` function.
#' @export
.DefaultSafetyWindowConst <- function() {
  SafetyWindowConst(
    gap = 7,
    follow = 7,
    follow_min = 14
  )
}

# Integration with knitr ----
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' We provide additional utility functions to allow human-friendly rendition of
#' crmPack objects in Markdown and Quarto files.  This file contains methods for
#' all design classes, not just those that are direct descendants of `Design`.
#'
#' @return a character string that represents the object in markdown.
#' @name knit_print
NULL

#' Internal Helper Functions for Validation of [`StartingDose`] Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Validates that the `StartingDose` object contains valid `starting_dose`.
#'
#' @param object (`StartingDose`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
#' @keywords internal
v_starting_dose <- function(object) {
  v <- Validate()
  v$check(
    test_number(object@starting_dose, finite = TRUE, lower = 0),
    "starting_dose must be a non-negative, finite number"
  )
  v$result()
}

# Helper class

#' `StartingDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StartingDose`] is a simple wrapper class for the `startingDose` slot of all
#' design classes. It is used internally by `knit_print` methods
#'
#' @slot starting_dose (`numeric`)\cr the starting dose
#' @rdname StartingDose-class
#' @keywords internal
.StartingDose <- setClass(
  Class = "StartingDose",
  slots = c(
    starting_dose = "numeric"
  ),
  prototype = prototype(
    starting_dose = 1
  ),
  validity = v_starting_dose,
  contains = "CrmPackClass"
)

## constructor ----

#' @rdname StartingDose-class
#' @param starting_dose (`positive_number`)\cr see slot definition.
StartingDose <- function(starting_dose) {
  new(
    "StartingDose",
    starting_dose = starting_dose
  )
}

#' @rdname StartingDose-class
#' @note Typically, end users will not use the `.DefaultStartingDose()` function.
.DefaultStartingDose <- function() {
  StartingDose(starting_dose = 5)
}

# Helper functions ----

h_knit_print_design <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  default_sections = NA,
  user_sections = NA,
  ignore_slots = c(),
  asis = TRUE
) {
  assert_flag(asis)
  # Because subsections use level + 1 and 6 is the lowest markdown header level
  assert_int(level, lower = 1, upper = 5)
  assert_character(title, any.missing = FALSE, len = 1L)

  slots_to_process <- setdiff(slotNames(x), ignore_slots)

  args <- list(...)
  units <- ifelse("units" %in% names(args), paste0(" ", args[["units"]]), "")
  section_labels <- h_prepare_section_labels(
    x,
    default_sections,
    user_sections
  )
  assert_subset(slots_to_process, names(section_labels))

  rv <- paste0(
    h_markdown_header(title, level = level),
    paste0(
      lapply(
        slots_to_process,
        function(nm) {
          tmp <- switch(
            nm,
            starting_dose = knit_print(
              StartingDose(x@starting_dose),
              asis = FALSE,
              level = level + 1L,
              ...
            ),
            startingDose = knit_print(
              StartingDose(x@startingDose),
              asis = FALSE,
              level = level + 1L,
              ...
            ),
            pl_cohort_size = ifelse(
              identical(slot(x, "pl_cohort_size"), CohortSizeConst(0)),
              "Placebo will not be administered in the trial.\n\n",
              knit_print(
                slot(x, "pl_cohort_size"),
                asis = FALSE,
                level = level + 1L,
                ...
              )
            ),
            {
              knit_print(slot(x, nm), asis = FALSE, level = level + 1L, ...)
            }
          )
          paste0(h_markdown_header(section_labels[nm], level + 1L), tmp)
        }
      ),
      collapse = "\n\n"
    ),
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @description A Helper Function to create Markdown Headers
#'
#' @param text (`character`) the header text
#' @param level (`positive_integer`) the level of the header.  Must be between 1 and 6.
#' @return the Markdown header string: a newline, `#` repeated `level` times,
#' a space, `text` followed by two newlines.
#' @keywords internal
#' @noRd
h_markdown_header <- function(text, level = 2L) {
  assert_character(text, any.missing = FALSE, len = 1L, min.chars = 2L)
  assert_int(level, lower = 1, upper = 6)

  paste0(
    "\n",
    stringr::str_dup("#", level),
    " ",
    text,
    "\n\n"
  )
}

#' Modify a Set of Default Slot Labels With Custom Custom Labels
#'
#' x (`S4`)\cr the S4 object for which slot labels are required
#' default_labels (`character`)\cr a vector of slot labels whose names are a
#' superset of the slot names of `x`
#' user_labels (`character`)\cr a vector of slot labels whose names are a
#' superset of the slot names of `x`.  Can be `NA`, in which case no updates
#' are made
#' @returns `default_labels` updated according to `user_labels`
#' @noRd
#' @keywords internal
h_prepare_section_labels <- function(x, default_labels, user_labels = NA) {
  assert_true(isS4(x))
  assert_character(default_labels, any.missing = FALSE)

  if (!any(is.na(user_labels))) {
    assert_character(user_labels, any.missing = FALSE)
    assert_subset(names(user_labels), slotNames(x))

    for (nm in names(user_labels)) {
      default_labels[nm] <- user_labels[nm]
    }
  }
  default_labels
}

# Methods ----

# StartingDose ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print StartingDose
knit_print.StartingDose <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  args <- list(...)
  units <- ifelse("units" %in% names(args), paste0(" ", args[["units"]]), "")
  rv <- paste0(
    "The starting dose is ",
    paste0(x@starting_dose, units),
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# RuleDesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param level (`positive_integer`) The level of the headings used to separate
#' slots.  Must be between 1 and 6.
#' @param title (`character`) The text of the heading of the section describing
#' the design
#' @param sections (`character`) a named vector of length at least 4 defining
#' the headings used to define the sections corresponding to the design's slots.
#' The element names must match the Design's slot names.
#' @rdname knit_print
#' @export
#' @method knit_print RuleDesign
knit_print.RuleDesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = 2L,
    title = "Design",
    default_sections = c(
      "nextBest" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "startingDose" = "Starting dose"
    ),
    user_sections = sections,
    asis = asis
  )
}

# Design ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print Design
knit_print.Design <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = 2L,
    title = "Design",
    default_sections = c(
      "nextBest" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "startingDose" = "Starting dose",
      "increments" = "Escalation rule",
      "stopping" = "Stopping rule",
      "model" = "Dose toxicity model",
      "pl_cohort_size" = "Use of placebo"
    ),
    user_sections = sections,
    asis = asis
  )
}

# DualDesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print DualDesign
knit_print.DualDesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(title, len = 1, any.missing = FALSE)
  assert_integer(level, len = 1, lower = 1, upper = 6)

  args <- list(...)
  bLabel <- ifelse(
    "biomarker_label" %in% names(args),
    args[["biomarker_label"]],
    "biomarker"
  )
  tLabel <- ifelse(
    "tox_label" %in% names(args),
    args[["tox_label"]],
    "toxicity"
  )

  if (is.na(sections)) {
    sections <- c(
      "model" = paste0("Dose-", tLabel, " and dose-", bLabel, " models")
    )
  } else {
    if (!("model" %in% names(sections))) {
      sections["model"] <- paste0(
        "Dose-",
        tLabel,
        " and dose-",
        bLabel,
        " models"
      )
    }
  }

  knit_print.Design(
    x,
    level = level,
    title = title,
    sections = sections,
    asis = asis,
    ...
  )
}

# DADesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print DADesign
knit_print.DADesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = 2L,
    title = "Design",
    default_sections = c(
      "nextBest" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "startingDose" = "Starting dose",
      "increments" = "Escalation rule",
      "stopping" = "Stopping rule",
      "model" = "Dose toxicity model",
      "pl_cohort_size" = "Use of placebo",
      "safetyWindow" = "Safety window"
    ),
    user_sections = sections,
    asis = asis
  )
}

# TDDesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print TDDesign
knit_print.TDDesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  knit_print.Design(
    x,
    level = level,
    title = title,
    sections = sections,
    asis = asis,
    ...
  )
}

# DualResponsesDesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print DualResponsesDesign
knit_print.DualResponsesDesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  knit_print.Design(
    x,
    level = level,
    title = title,
    sections = sections,
    asis = asis,
    ...
  )
}

# DesignOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print DesignOrdinal
knit_print.DesignOrdinal <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = 2L,
    title = "Design",
    default_sections = c(
      "next_best" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "starting_dose" = "Starting dose",
      "increments" = "Escalation rule",
      "stopping" = "Stopping rule",
      "model" = "Dose toxicity model",
      "pl_cohort_size" = "Use of placebo"
    ),
    user_sections = sections,
    asis = asis
  )
}

# DesignGrouped ----

# Needs special handling because of the empty models and nested rules in the
# mono and combo slots and because of the many slots that are of built-in types
# rather than being of crmPack-specific types

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print DesignGrouped
knit_print.DesignGrouped <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = c(
    "model" = "Dose toxicity model",
    "mono" = "Monotherapy rules",
    "combo" = "Combination therapy rules",
    "other" = "Other details"
  ),
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(title, len = 1, any.missing = FALSE)
  assert_integer(level, len = 1, lower = 1, upper = 6)

  rv <- paste0(
    h_markdown_header(sections["model"], level = level),
    knit_print(x@model, asis = FALSE, ...),
    h_markdown_header(sections["mono"], level = level),
    h_knit_print_design(
      x@mono,
      asis = FALSE,
      level = level + 1L,
      ignore_slots = c("model"),
      default_sections = c(
        "nextBest" = "Dose recommendation",
        "cohort_size" = "Cohort size",
        "data" = "Observed monotherapy data",
        "startingDose" = "Starting dose",
        "increments" = "Escalation rule",
        "stopping" = "Stopping rule",
        "pl_cohort_size" = "Use of placebo"
      ),
      sections = sections[["mono"]],
      ...
    ),
    h_markdown_header(sections["combo"], level = level),
    h_knit_print_design(
      x@combo,
      asis = FALSE,
      level = level + 1L,
      ignore_slots = "model",
      default_sections = c(
        "nextBest" = "Dose recommendation",
        "cohort_size" = "Cohort size",
        "data" = "Observed combination therapy data",
        "startingDose" = "Starting dose",
        "increments" = "Escalation rule",
        "stopping" = "Stopping rule",
        "pl_cohort_size" = "Use of placebo"
      ),
      sections = sections[["combo"]],
      ...
    ),
    h_markdown_header(sections["other"], level = level),
    ifelse(
      x@first_cohort_mono_only,
      paste0(
        "No combination dosing may occur until the results of at least one ",
        "monotherapy cohort are available.\n\n"
      ),
      "Simultaneous combination and monotherapy dosing is permitted from the outset.\n\n"
    ),
    ifelse(
      x@same_dose_for_start,
      paste0(
        "When monotherapy and combination therapy are used in the same cohort ",
        "for the first time, the same dose must be used for both regimens.\n\n"
      ),
      paste0(
        "When monotherapy and combination therapy are used in the same cohort ",
        "for the first time, the use of a different dose in each regimen is permitted.\n\n"
      )
    ),
    ifelse(
      x@same_dose_for_all,
      paste0(
        "Whenever monotherapy and combination therapy are used in the same cohort, ",
        "the same dose must be used for both regimens.\n\n"
      ),
      paste0(
        "Whenever monotherapy and combination therapy are used in the same cohort, ",
        "the use of a different dose in each regimen is permitted.\n\n"
      )
    )
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# TDsamplesDesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print TDsamplesDesign
knit_print.TDsamplesDesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = level,
    title = title,
    default_sections = c(
      "nextBest" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "startingDose" = "Starting dose",
      "model" = "Dose toxicity model",
      "stopping" = "Stopping rule",
      "increments" = "Escalation rule",
      "pl_cohort_size" = "Use of placebo"
    ),
    user_sections = sections,
    asis = asis
  )
}

# DualResponsesDesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print DualResponsesDesign
knit_print.DualResponsesDesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = level,
    title = title,
    default_sections = c(
      "nextBest" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "startingDose" = "Starting dose",
      "increments" = "Escalation rule",
      "stopping" = "Stopping rule",
      "model" = "Dose-toxicity model",
      "eff_model" = "Dose-efficacy model",
      "pl_cohort_size" = "Use of placebo"
    ),
    ignore_sections = c("model", "eff_model"),
    sections = sections,
    asis = asis
  )
}

# DualResponsesSamplesDesign ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print DualResponsesSamplesDesign
knit_print.DualResponsesSamplesDesign <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = level,
    title = title,
    default_sections = c(
      "nextBest" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "startingDose" = "Starting dose",
      "increments" = "Escalation rule",
      "stopping" = "Stopping rule",
      "model" = "Dose-toxicity model",
      "eff_model" = "Dose-efficacy model",
      "pl_cohort_size" = "Use of placebo"
    ),
    ignore_sections = c("model", "eff_model"),
    sections = sections,
    asis = asis
  )
}

# RuleDesignOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.RuleDesign
#' @rdname knit_print
#' @export
#' @method knit_print RuleDesignOrdinal
knit_print.RuleDesignOrdinal <- function(
  x,
  ...,
  level = 2L,
  title = "Design",
  sections = NA,
  asis = TRUE
) {
  h_knit_print_design(
    x,
    ...,
    level = 2L,
    title = "Design",
    default_sections = c(
      "next_best" = "Dose recommendation",
      "cohort_size" = "Cohort size",
      "data" = "Observed data",
      "starting_dose" = "Starting dose"
    ),
    user_sections = sections,
    asis = asis
  )
}

#' @include Data-methods.R
#' @include Design-class.R
#' @include McmcOptions-class.R
#' @include Rules-methods.R
#' @include Simulations-class.R
#' @include helpers.R
#' @include mcmc.R
NULL

# nolint start

## ============================================================

##' Simulate outcomes from a CRM design
##'
##' @param object the \code{\linkS4class{Design}} object we want to simulate
##' data from
##' @param nsim the number of simulations (default: 1)
##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity. Additional arguments can be supplied
##' in \code{args}.
##' @param args data frame with arguments for the \code{truth} function. The
##' column names correspond to the argument names, the rows to the values of the
##' arguments. The rows are appropriately recycled in the \code{nsim}
##' simulations. In order to produce outcomes from the posterior predictive
##' distribution, e.g, pass an \code{object} that contains the data observed so
##' far, \code{truth} contains the \code{prob} function from the model in
##' \code{object}, and \code{args} contains posterior samples from the model.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##' @param derive a named list of functions which derives statistics, based on the
##' vector of posterior MTD samples. Each list element must therefore accept
##' one and only one argument, which is a numeric vector, and return a number.
##'
##' @return an object of class \code{\linkS4class{Simulations}}
##'
##' @example examples/design-method-simulate-Design.R
##' @export
##' @importFrom parallel detectCores
##' @keywords methods
setMethod(
  "simulate",
  signature = signature(
    object = "Design",
    nsim = "ANY",
    seed = "ANY"
  ),
  def = function(
    object,
    nsim = 1L,
    seed = NULL,
    truth,
    args = NULL,
    firstSeparate = FALSE,
    mcmcOptions = McmcOptions(),
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5),
    derive = list(),
    ...
  ) {
    ## checks and extracts
    assert_function(truth)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    args <- as.data.frame(args)
    nArgs <- max(nrow(args), 1L)

    ## seed handling
    RNGstate <- set_seed(seed)

    ## from this,
    ## generate the individual seeds for the simulation runs
    simSeeds <- sample.int(n = 2147483647, size = as.integer(nsim))

    ## the function to produce the run a single simulation
    ## with index "iterSim"
    runSim <- function(iterSim) {
      ## set the seed for this run
      set.seed(simSeeds[iterSim])

      ## what is now the argument for the truth?
      ## (appropriately recycled)
      thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

      ## start the simulated data with the provided one
      thisData <- object@data

      # In case there are placebo
      if (thisData@placebo) {
        ## what is the probability for tox. at placebo?
        thisProb.PL <- h_this_truth(
          object@data@doseGrid[1],
          thisArgs,
          truth
        )
      }

      ## shall we stop the trial?
      ## First, we want to continue with the starting dose.
      ## This variable is updated after each cohort in the loop.
      stopit <- FALSE

      ## what is the next dose to be used?
      ## initialize with starting dose
      thisDose <- object@startingDose

      ## inside this loop we simulate the whole trial, until stopping
      while (!stopit) {
        ## what is the probability for tox. at this dose?
        thisProb <- h_this_truth(
          thisDose,
          thisArgs,
          truth
        )

        ## what is the cohort size at this dose?
        thisSize <- size(object@cohort_size, dose = thisDose, data = thisData)

        ## In case there are placebo
        if (thisData@placebo) {
          thisSize.PL <- size(
            object@pl_cohort_size,
            dose = thisDose,
            data = thisData
          )
        }

        thisData <- h_determine_dlts(
          data = thisData,
          dose = thisDose,
          prob = thisProb,
          prob_placebo = thisProb.PL,
          cohort_size = thisSize,
          cohort_size_placebo = thisSize.PL,
          dose_grid = object@data@doseGrid[1],
          first_separate = firstSeparate
        )

        ## what is the dose limit?
        doselimit <- maxDose(object@increments, data = thisData)

        ## generate samples from the model
        thisSamples <- mcmc(
          data = thisData,
          model = object@model,
          options = mcmcOptions
        )

        ## => what is the next best dose?
        thisDose <- nextBest(
          object@nextBest,
          doselimit = doselimit,
          samples = thisSamples,
          model = object@model,
          data = thisData
        )$value

        ## evaluate stopping rules
        stopit <- stopTrial(
          object@stopping,
          dose = thisDose,
          samples = thisSamples,
          model = object@model,
          data = thisData
        )

        stopit_results <- h_unpack_stopit(stopit)
      }

      ## get the fit
      thisFit <- fit(
        object = thisSamples,
        model = object@model,
        data = thisData
      )

      # Get the MTD estimate from the samples.

      target_dose_samples <- dose(
        mean(object@nextBest@target),
        model = object@model,
        samples = thisSamples
      )

      # Create a function for additional statistical summary.

      additional_stats <- lapply(derive, function(f) f(target_dose_samples))

      ## return the results
      thisResult <-
        list(
          data = thisData,
          dose = thisDose,
          fit = subset(thisFit, select = c(middle, lower, upper)),
          stop = attr(
            stopit,
            "message"
          ),
          report_results = stopit_results,
          additional_stats = additional_stats
        )
      return(thisResult)
    }

    resultList <- get_result_list(
      fun = runSim,
      nsim = nsim,
      vars = c(
        "simSeeds",
        "args",
        "nArgs",
        "firstSeparate",
        "truth",
        "object",
        "mcmcOptions"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    # format simulation output
    simulations_output <- h_simulations_output_format(resultList)

    ## return the results in the Simulations class object
    ret <- Simulations(
      data = simulations_output$dataList,
      doses = simulations_output$recommendedDoses,
      fit = simulations_output$fitList,
      stop_report = simulations_output$stop_matrix,
      stop_reasons = simulations_output$stopReasons,
      additional_stats = simulations_output$additional_stats,
      seed = RNGstate
    )

    return(ret)
  }
)


##' Simulate outcomes from a rule-based design
##'
##' @param object the \code{\linkS4class{RuleDesign}} object we want to simulate
##' data from
##' @param nsim the number of simulations (default: 1)
##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity. Additional arguments can be supplied
##' in \code{args}.
##' @param args data frame with arguments for the \code{truth} function. The
##' column names correspond to the argument names, the rows to the values of the
##' arguments. The rows are appropriately recycled in the \code{nsim}
##' simulations.
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##'
##' @return an object of class \code{\linkS4class{GeneralSimulations}}
##'
##' @example examples/design-method-simulate-RuleDesign.R
##' @export
##' @keywords methods
setMethod(
  "simulate",
  signature = signature(
    object = "RuleDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  def = function(
    object,
    nsim = 1L,
    seed = NULL,
    truth,
    args = NULL,
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5L),
    ...
  ) {
    ## checks and extracts
    assert_function(truth)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    args <- as.data.frame(args)
    nArgs <- max(nrow(args), 1L)

    ## seed handling
    RNGstate <- set_seed(seed)

    ## from this,
    ## generate the individual seeds for the simulation runs
    simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

    ## the function to produce the run a single simulation
    ## with index "iterSim"
    runSim <- function(iterSim) {
      ## set the seed for this run
      set.seed(simSeeds[iterSim])

      ## what is now the argument for the truth?
      ## (appropriately recycled)
      thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

      ## so this truth is...
      thisTruth <- function(dose) {
        do.call(
          truth,
          ## First argument: the dose
          c(
            dose,
            ## Following arguments
            thisArgs
          )
        )
      }

      ## start the simulated data with the provided one
      thisData <- object@data

      ## shall we stop the trial?
      ## First, we want to continue with the starting dose.
      ## This variable is updated after each cohort in the loop.
      stopit <- FALSE

      ## what is the next dose to be used?
      ## initialize with starting dose
      thisDose <- object@startingDose

      ## inside this loop we simulate the whole trial, until stopping
      while (!stopit) {
        ## what is the probability for tox. at this dose?
        thisProb <- thisTruth(thisDose)

        ## what is the cohort size at this dose?
        thisSize <- size(object@cohort_size, dose = thisDose, data = thisData)

        ## simulate DLTs
        thisDLTs <- rbinom(
          n = thisSize,
          size = 1L,
          prob = thisProb
        )

        ## update the data with this cohort
        thisData <- update(
          object = thisData,
          x = thisDose,
          y = thisDLTs
        )

        ## evaluate the rule
        thisOutcome <- nextBest(object@nextBest, data = thisData)

        thisDose <- thisOutcome$value
        stopit <- thisOutcome$stopHere
      }

      ## return the results
      thisResult <-
        list(
          data = thisData,
          dose = thisDose
        )

      return(thisResult)
    }

    resultList <- get_result_list(
      fun = runSim,
      nsim = nsim,
      vars = c(
        "simSeeds",
        "args",
        "nArgs",
        "truth",
        "object"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    ## put everything in the GeneralSimulations format:

    ## setup the list for the simulated data objects
    dataList <- lapply(resultList, "[[", "data")

    ## the vector of the final dose recommendations
    recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))

    ## return the results in the GeneralSimulations class object
    ret <- GeneralSimulations(
      data = dataList,
      doses = recommendedDoses,
      seed = RNGstate
    )

    return(ret)
  }
)


##' Simulate outcomes from a dual-endpoint design
##'
##' @param object the \code{\linkS4class{DualDesign}} object we want to simulate
##' data from
##' @param nsim the number of simulations (default: 1)
##' @param seed see \code{\link{set_seed}}
##' @param trueTox a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity. Additional arguments can be supplied
##' in \code{args}.
##' @param trueBiomarker a function which takes as input a dose (vector) and
##' returns the true biomarker level (vector). Additional arguments can be
##' supplied in \code{args}.
##' @param args data frame with arguments for the \code{trueTox} and
##' \code{trueBiomarker} function. The column names correspond to the argument
##' names, the rows to the values of the arguments. The rows are appropriately
##' recycled in the \code{nsim} simulations.
##' @param sigma2W variance for the biomarker measurements
##' @param rho correlation between toxicity and biomarker measurements (default:
##' 0)
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##' @param derive a named list of functions which derives statistics, based on the
##' vector of posterior MTD samples. Each list element must therefore accept
##' one and only one argument, which is a numeric vector, and return a number.
##'
##' @return an object of class \code{\linkS4class{DualSimulations}}
##'
##' @example examples/design-method-simulate-DualDesign.R
##' @importFrom mvtnorm rmvnorm
##' @export
##' @keywords methods
setMethod(
  "simulate",
  signature = signature(object = "DualDesign"),
  def = function(
    object,
    nsim = 1L,
    seed = NULL,
    trueTox,
    trueBiomarker,
    args = NULL,
    sigma2W,
    rho = 0,
    firstSeparate = FALSE,
    mcmcOptions = McmcOptions(),
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5),
    derive = list(),
    ...
  ) {
    ## checks and extracts
    assert_function(trueTox)
    assert_function(trueBiomarker)
    assert_number(sigma2W, lower = 0)
    assert_number(rho, lower = -1, upper = 1)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    args <- as.data.frame(args)
    nArgs <- max(nrow(args), 1L)

    ## get names of arguments (excluding the first one which is the dose)
    trueToxArgnames <- names(formals(trueTox))[-1]
    trueBiomarkerArgnames <- names(formals(trueBiomarker))[-1]

    ## this is the covariance matrix we assume:
    trueCov <- matrix(
      c(
        sigma2W,
        sqrt(sigma2W) * rho,
        sqrt(sigma2W) * rho,
        1
      ),
      nrow = 2,
      byrow = TRUE
    )

    ## seed handling
    RNGstate <- set_seed(seed)

    ## from this,
    ## generate the individual seeds for the simulation runs
    simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

    ## the function to produce the run a single simulation
    ## with index "iterSim"
    runSim <- function(iterSim) {
      ## set the seed for this run
      set.seed(simSeeds[iterSim])

      ## what is now the argument for the true functions?
      ## (appropriately recycled)
      thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

      ## so the true tox function is:
      thisTrueTox <- function(dose) {
        do.call(
          trueTox,
          ## First argument: the dose
          c(
            dose,
            ## Following arguments: take only those that
            ## are required by the tox function
            as.list(thisArgs)[trueToxArgnames]
          )
        )
      }

      ## and the true biomarker function is:
      thisTrueBiomarker <- function(dose) {
        do.call(
          trueBiomarker,
          ## First argument: the dose
          c(
            dose,
            ## Following arguments: take only those that
            ## are required by the biomarker function
            as.list(thisArgs)[trueBiomarkerArgnames]
          )
        )
      }

      ## start the simulated data with the provided one
      thisData <- object@data

      ## shall we stop the trial?
      ## First, we want to continue with the starting dose.
      ## This variable is updated after each cohort in the loop.
      stopit <- FALSE

      ## what is the next dose to be used?
      ## initialize with starting dose
      thisDose <- object@startingDose

      # In case there are placebo, extract true Toxicity and Efficacy for placebo
      if (thisData@placebo) {
        ## what is the probability for tox. at placebo?
        thisProb.PL <- thisTrueTox(object@data@doseGrid[1])
        thisMeanZ.PL <- qlogis(thisProb.PL)

        ## what is the biomarker mean at placebo?
        thisMeanBiomarker.PL <- thisTrueBiomarker(object@data@doseGrid[1])
      }

      ## inside this loop we simulate the whole trial, until stopping
      while (!stopit) {
        ## what is the probability for tox. at this dose?
        thisProb <- thisTrueTox(thisDose)
        ## and the transformation to the z scale is:
        thisMeanZ <- qlogis(thisProb)

        ## what is the biomarker mean at this dose?
        thisMeanBiomarker <- thisTrueBiomarker(thisDose)

        ## what is the cohort size at this dose?
        thisSize <- size(object@cohort_size, dose = thisDose, data = thisData)

        ## In case there are placebo
        ## what is the cohort size at this dose for Placebo?
        if (thisData@placebo) {
          thisSize.PL <- size(
            object@pl_cohort_size,
            dose = thisDose,
            data = thisData
          )
        }

        ## simulate tox and biomarker response: depends on whether we
        ## separate the first patient or not.
        tmp <-
          if (firstSeparate && (thisSize > 1L)) {
            ## dose the first patient
            tmpStart <- mvtnorm::rmvnorm(
              n = 1,
              mean = c(
                thisMeanBiomarker,
                thisMeanZ
              ),
              sigma = trueCov
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              tmpStart.PL <- mvtnorm::rmvnorm(
                n = 1,
                mean = c(
                  thisMeanBiomarker.PL,
                  thisMeanZ.PL
                ),
                sigma = trueCov
              )
            }

            ## if there is no DLT:
            if (tmpStart[, 2] < 0) {
              ## enroll the remaining patients
              tmpStart <-
                rbind(
                  tmpStart,
                  mvtnorm::rmvnorm(
                    n = thisSize - 1,
                    mean = c(
                      thisMeanBiomarker,
                      thisMeanZ
                    ),
                    sigma = trueCov
                  )
                )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                tmpStart.PL <-
                  rbind(
                    tmpStart.PL,
                    mvtnorm::rmvnorm(
                      n = thisSize.PL,
                      mean = c(
                        thisMeanBiomarker.PL,
                        thisMeanZ.PL
                      ),
                      sigma = trueCov
                    )
                  )
              }
            }

            if (thisData@placebo && (thisSize.PL > 0L)) {
              list(tmpStart = tmpStart, tmpStart.PL = tmpStart.PL)
            } else {
              list(tmpStart = tmpStart)
            }
          } else {
            ## we can directly dose all patients
            tmpStart <- mvtnorm::rmvnorm(
              n = thisSize,
              mean = c(
                thisMeanBiomarker,
                thisMeanZ
              ),
              sigma = trueCov
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              tmpStart.PL <- mvtnorm::rmvnorm(
                n = thisSize.PL,
                mean = c(
                  thisMeanBiomarker.PL,
                  thisMeanZ.PL
                ),
                sigma = trueCov
              )
            }

            if (thisData@placebo && (thisSize.PL > 0L)) {
              list(tmpStart = tmpStart, tmpStart.PL = tmpStart.PL)
            } else {
              list(tmpStart = tmpStart)
            }
          }

        ## extract biomarker and DLT samples
        thisBiomarkers <- tmp$tmpStart[, 1]
        thisDLTs <- as.integer(tmp$tmpStart[, 2] > 0)

        # in case there are placebo
        if (thisData@placebo && (thisSize.PL > 0L)) {
          thisBiomarkers.PL <- tmp$tmpStart.PL[, 1]
          thisDLTs.PL <- as.integer(tmp$tmpStart.PL[, 2] > 0)

          ## update the data first with placebo...
          thisData <- update(
            object = thisData,
            x = object@data@doseGrid[1],
            y = thisDLTs.PL,
            w = thisBiomarkers.PL,
            check = FALSE
          )

          ### ... and then with active dose
          thisData <- update(
            object = thisData,
            x = thisDose,
            y = thisDLTs,
            w = thisBiomarkers,
            new_cohort = FALSE
          )
        } else {
          thisData <- update(
            object = thisData,
            x = thisDose,
            y = thisDLTs,
            w = thisBiomarkers
          )
        }

        ## what is the dose limit?
        doselimit <- maxDose(object@increments, data = thisData)

        ## generate samples from the model
        thisSamples <- mcmc(
          data = thisData,
          model = object@model,
          options = mcmcOptions
        )

        ## => what is the next best dose?
        thisDose <- nextBest(
          object@nextBest,
          doselimit = doselimit,
          samples = thisSamples,
          model = object@model,
          data = thisData
        )$value

        ## evaluate stopping rules
        stopit <- stopTrial(
          object@stopping,
          dose = thisDose,
          samples = thisSamples,
          model = object@model,
          data = thisData
        )
        stopit_results <- h_unpack_stopit(stopit)
      }

      ## get the fit
      thisFit <- fit(
        object = thisSamples,
        model = object@model,
        data = thisData
      )

      # Get the MTD estimate from the samples.

      target_dose_samples <- dose(
        mean(object@nextBest@target),
        model = object@model,
        samples = thisSamples
      )

      # Create a function for additional statistical summary.

      additional_stats <- lapply(derive, function(f) f(target_dose_samples))

      ## return the results
      thisResult <-
        list(
          data = thisData,
          dose = thisDose,
          fitTox = subset(thisFit, select = c(middle, lower, upper)),
          fit_biomarker = subset(
            thisFit,
            select = c(
              middleBiomarker,
              lowerBiomarker,
              upperBiomarker
            )
          ),
          rho_est = median(thisSamples@data$rho),
          sigma2w_est = median(1 / thisSamples@data$precW),
          stop = attr(
            stopit,
            "message"
          ),
          additional_stats = additional_stats,
          report_results = stopit_results
        )

      return(thisResult)
    }

    resultList <- get_result_list(
      fun = runSim,
      nsim = nsim,
      vars = c(
        "simSeeds",
        "args",
        "nArgs",
        "firstSeparate",
        "trueTox",
        "trueBiomarker",
        "trueCov",
        "object",
        "mcmcOptions"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    ## put everything in the Simulations format:

    ## setup the list for the simulated data objects
    dataList <- lapply(resultList, "[[", "data")

    ## the vector of the final dose recommendations
    recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))

    ## vector of rho estimates
    rhoEstimates <- as.numeric(sapply(resultList, "[[", "rho_est"))

    ## vector of sigma2W estimates
    sigma2Westimates <- as.numeric(sapply(resultList, "[[", "sigma2w_est"))

    ## setup the list for the final tox fits
    fitToxList <- lapply(resultList, "[[", "fitTox")

    ## setup the list for the final biomarker fits
    fitBiomarkerList <- lapply(resultList, "[[", "fit_biomarker")

    ## the reasons for stopping
    stopReasons <- lapply(resultList, "[[", "stop")

    # individual stopping rule results as matrix, labels as column names
    stop_results <- lapply(resultList, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))

    ## For dual simulations summary of additional statistics.
    additional_stats <- lapply(resultList, "[[", "additional_stats")

    ## return the results in the DualSimulations class object
    ret <- DualSimulations(
      data = dataList,
      doses = recommendedDoses,
      rho_est = rhoEstimates,
      sigma2w_est = sigma2Westimates,
      fit = fitToxList,
      fit_biomarker = fitBiomarkerList,
      stop_report = stop_report,
      stop_reasons = stopReasons,
      additional_stats = additional_stats,
      seed = RNGstate
    )

    return(ret)
  }
)


## ============================================================

##' Obtain hypothetical trial course table for a design
##'
##' This generic function takes a design and generates a dataframe
##' showing the beginning of several hypothetical trial courses under
##' the design. This means, from the generated dataframe one can read off:
##' - how many cohorts are required in the optimal case (no DLTs observed) in
##'   order to reach the highest dose of the specified dose grid (or until
##'   the stopping rule is fulfilled)
##' - assuming no DLTs are observed until a certain dose level, what the next
##'   recommended dose is for all possible number of DLTs observed
##' - the actual relative increments that will be used in these cases
##' - whether the trial would stop at a certain cohort
##' Examining the "single trial" behavior of a dose escalation design is
##' the first important step in evaluating a design, and cannot be replaced by
##' studying solely the operating characteristics in "many trials". The cohort
##' sizes are also taken from the design, assuming no DLTs occur until the dose
##' listed.
##'
##' @param object the design (\code{\linkS4class{Design}} or
##' \code{\linkS4class{RuleDesign}} object) we want to examine
##' @param \dots additional arguments (see methods)
##' @param maxNoIncrement maximum number of contiguous next doses at 0
##' DLTs that are the same as before, i.e. no increment (default to 100)
##'
##' @return The data frame
##'
##' @export
##' @keywords methods regression
setGeneric(
  "examine",
  def = function(object, ..., maxNoIncrement = 100L) {
    ## check maxNoIncrement argument
    assert_count(maxNoIncrement, positive = TRUE)

    ## there should be no default method,
    ## therefore just forward to next method!
    standardGeneric("examine")
  },
  valueClass = "data.frame"
)


##' @describeIn examine Examine a model-based CRM
##'
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##'
##' @example examples/design-method-examine-Design.R
setMethod(
  "examine",
  signature = signature(object = "Design"),
  def = function(object, mcmcOptions = McmcOptions(), ..., maxNoIncrement) {
    ## start with the empty table
    ret <- data.frame(
      dose = numeric(),
      DLTs = integer(),
      nextDose = numeric(),
      stop = logical(),
      increment = integer()
    )

    ## start the base data with the provided one
    baseData <- object@data

    ## are we finished and can stop?
    stopit <- FALSE

    ## counter how many contiguous doses at 0 DLTs with
    ## no increment
    noIncrementCounter <- 0L

    ## what is the next dose to be used?
    ## initialize with starting dose
    thisDose <- object@startingDose

    ## inside this loop we continue filling up the table, until
    ## stopping
    while (!stopit) {
      ## what is the cohort size at this dose?
      thisSize <- size(object@cohort_size, dose = thisDose, data = baseData)

      if (baseData@placebo) {
        thisSize.PL <- size(
          object@pl_cohort_size,
          dose = thisDose,
          data = baseData
        )
      }

      ## for all possible number of DLTs:
      for (numDLTs in 0:thisSize) {
        ## update data with corresponding DLT vector
        if (baseData@placebo && (thisSize.PL > 0L)) {
          thisData <- update(
            object = baseData,
            x = baseData@doseGrid[1],
            y = rep(0, thisSize.PL),
            check = FALSE
          )

          thisData <-
            update(
              object = thisData,
              x = thisDose,
              y = rep(
                x = c(0, 1),
                times = c(
                  thisSize - numDLTs,
                  numDLTs
                )
              ),
              new_cohort = FALSE
            )
        } else {
          thisData <-
            update(
              object = baseData,
              x = thisDose,
              y = rep(
                x = c(0, 1),
                times = c(
                  thisSize - numDLTs,
                  numDLTs
                )
              )
            )
        }

        ## what is the dose limit?
        doselimit <- maxDose(object@increments, data = thisData)

        ## generate samples from the model
        thisSamples <- mcmc(
          data = thisData,
          model = object@model,
          options = mcmcOptions
        )

        ## => what is the next best dose?
        nextDose <- nextBest(
          object@nextBest,
          doselimit = doselimit,
          samples = thisSamples,
          model = object@model,
          data = thisData
        )$value

        ## compute relative increment in percent
        thisIncrement <-
          round((nextDose - thisDose) / thisDose * 100)

        ## evaluate stopping rules
        stopThisTrial <- stopTrial(
          object@stopping,
          dose = nextDose,
          samples = thisSamples,
          model = object@model,
          data = thisData
        )

        ## append information to the data frame
        ret <- rbind(
          ret,
          list(
            dose = thisDose,
            DLTs = numDLTs,
            nextDose = nextDose,
            stop = stopThisTrial,
            increment = as.integer(thisIncrement)
          )
        )
      }

      ## change base data
      if (baseData@placebo && (thisSize.PL > 0L)) {
        baseData <-
          update(
            object = baseData,
            x = baseData@doseGrid[1],
            y = rep(0, thisSize.PL),
            check = FALSE
          )

        baseData <-
          update(
            object = baseData,
            x = thisDose,
            y = rep(0, thisSize),
            new_cohort = FALSE
          )
      } else {
        baseData <-
          update(
            object = baseData,
            x = thisDose,
            y = rep(0, thisSize)
          )
      }

      ## what are the results if 0 DLTs?
      resultsNoDLTs <- subset(
        tail(ret, thisSize + 1),
        dose == thisDose & DLTs == 0
      )

      ## what is the new dose then accordingly?
      newDose <- as.numeric(resultsNoDLTs$nextDose)

      ## what is the difference to the previous dose?
      doseDiff <- newDose - thisDose

      ## update the counter for no increments of the dose
      if (doseDiff == 0) {
        noIncrementCounter <- noIncrementCounter + 1L
      } else {
        noIncrementCounter <- 0L
      }

      ## would stopping rule be fulfilled already?
      stopAlready <- resultsNoDLTs$stop

      ## update dose
      thisDose <- newDose

      ## too many times no increment?
      stopNoIncrement <- (noIncrementCounter >= maxNoIncrement)
      if (stopNoIncrement) {
        warning(paste(
          "Stopping because",
          noIncrementCounter,
          "times no increment vs. previous dose"
        ))
      }

      ## check if we can stop:
      ## either when we have reached the highest dose in the
      ## next cohort, or when the stopping rule is already
      ## fulfilled, or when too many times no increment
      stopit <- (thisDose >= max(object@data@doseGrid)) ||
        stopAlready ||
        stopNoIncrement
    }

    return(ret)
  }
)


##' @describeIn examine Examine a rule-based design
##' @example examples/design-method-examine-RuleDesign.R
setMethod(
  "examine",
  signature = signature(object = "RuleDesign"),
  def = function(object, ..., maxNoIncrement) {
    ## start with the empty table
    ret <- data.frame(
      dose = numeric(),
      DLTs = integer(),
      nextDose = numeric(),
      stop = logical(),
      increment = integer()
    )

    ## start the base data with the provided one
    baseData <- object@data

    ## are we finished and can stop?
    stopit <- FALSE

    ## counter how many contiguous doses at 0 DLTs with
    ## no increment
    noIncrementCounter <- 0L

    ## what is the next dose to be used?
    ## initialize with starting dose
    thisDose <- object@startingDose

    ## inside this loop we continue filling up the table, until
    ## stopping
    while (!stopit) {
      ## what is the cohort size at this dose?
      thisSize <- size(object@cohort_size, dose = thisDose, data = baseData)

      ## for all possible number of DLTs:
      for (numDLTs in 0:thisSize) {
        ## update data with corresponding DLT vector
        thisData <-
          update(
            object = baseData,
            x = thisDose,
            y = rep(
              x = c(0, 1),
              times = c(
                thisSize - numDLTs,
                numDLTs
              )
            )
          )

        ## evaluate the rule
        thisOutcome <- nextBest(object@nextBest, data = thisData)

        ## next dose
        nextDose <- thisOutcome$value

        ## do we stop here?
        stopThisTrial <- thisOutcome$stopHere

        ## compute relative increment in percent
        thisIncrement <-
          round((nextDose - thisDose) / thisDose * 100)

        ## append information to the data frame
        ret <- rbind(
          ret,
          list(
            dose = thisDose,
            DLTs = numDLTs,
            nextDose = nextDose,
            stop = stopThisTrial,
            increment = as.integer(thisIncrement)
          )
        )
      }

      ## change base data
      baseData <-
        update(
          object = baseData,
          x = thisDose,
          y = rep(0, thisSize)
        )

      ## what are the results if 0 DLTs?
      resultsNoDLTs <- subset(
        tail(ret, thisSize + 1),
        dose == thisDose & DLTs == 0
      )

      ## what is the new dose then accordingly?
      newDose <- as.numeric(resultsNoDLTs$nextDose)

      ## what is the difference to the previous dose?
      doseDiff <- newDose - thisDose

      ## update the counter for no increments of the dose
      if (doseDiff == 0) {
        noIncrementCounter <- noIncrementCounter + 1L
      } else {
        noIncrementCounter <- 0L
      }

      ## would stopping rule be fulfilled already?
      stopAlready <- resultsNoDLTs$stop

      ## update dose
      thisDose <- newDose

      ## too many times no increment?
      stopNoIncrement <- (noIncrementCounter >= maxNoIncrement)
      if (stopNoIncrement) {
        warning(paste(
          "Stopping because",
          noIncrementCounter,
          "times no increment vs. previous dose"
        ))
      }

      ## check if we can stop:
      ## either when we have reached the highest dose in the
      ## next cohort, or when the stopping rule is already
      ## fulfilled, or when too many times no increment
      stopit <- (thisDose >= max(object@data@doseGrid)) ||
        stopAlready ||
        stopNoIncrement
    }

    return(ret)
  }
)

##' @describeIn examine Examine a model-based CRM
##'
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##'
##' @example examples/design-method-examine-DADesign.R
setMethod(
  "examine",
  signature = signature(object = "DADesign"),
  def = function(object, mcmcOptions = McmcOptions(), ..., maxNoIncrement) {
    # A function to return follow up fulfull yes (TRUE) vs no (FALSE);
    ready_to_open <- function(day, window, thisSurv) {
      size <- length(thisSurv)
      # the date the patient starts;
      start_time <- apply(rbind(thisSurv[-size], window$patientGap[-1]), 2, min)
      # the relative time for each patient on the specified "date";
      individule_check <- day - cumsum(c(0, start_time))
      # the minial number should be 0;
      individule_check[individule_check < 0] <- 0
      follow_up <- apply(rbind(thisSurv, individule_check), 2, min)
      return(
        all(
          (follow_up - apply(rbind(window$patientFollow, thisSurv), 2, min)) >=
            0
        ) &
          (max(follow_up) >= min(window$patientFollowMin, max(thisSurv)))
      )
    }

    ## assume we have surfficient patients, i.e. patient can be immediately enrolled
    ## once the trial accumulation is open. This function will tell you when to open
    ## the next cohort;
    # this function applys to all trials;
    nextOpen <- function(window, thisSurv) {
      size <- length(thisSurv)

      window$patientGap <- window$patientGap[1:size] ## if length(window$pt)>length(thisSurv), assume the first length(thisSurv) patients were enrolled;
      ## if the DLT happens before the end of DLT window, then the next
      ## cohort/enrollment of the next patient would happened earlier;
      start_time <- apply(rbind(thisSurv[-size], window$patientGap[-1]), 2, min)
      # duration of the cohort (all DLT windows finished);
      maxT <- max(thisSurv + cumsum(c(0, start_time)))

      meetrequire <- sapply(1:maxT, function(i) {
        ready_to_open(i, window, thisSurv)
      })
      if (sum(meetrequire) > 0) {
        # the earliest time that the require is met;
        time <- min(c(1:maxT)[meetrequire])
      } else {
        time <- maxT
      }

      return(time)
    }

    ## start with the empty table
    ret <- data.frame(
      DLTsearly_1 = integer(), ## JZ: add a cohort index;
      dose = numeric(),
      DLTs = integer(),
      nextDose = numeric(),
      stop = logical(),
      increment = integer()
    )

    ## start the base data with the provided one
    baseData <- object@data

    ## are we finished and can stop?
    stopit <- FALSE

    ## what is the next dose to be used?
    ## initialize with starting dose
    thisDose <- object@startingDose

    ## initial {fact} variables;
    factDLTs <- baseData@y
    factSurv <- baseData@u
    factT0 <- baseData@t0

    ## Initiate "trialtime" which is zero. This is the global time for studies;
    trialtime <- 0

    ## when the current cohort open?
    pretime <- 0

    ## the duration of DLT window
    Tmax <- baseData@Tmax

    ## number of patients with un-completed DLT window;
    ## assume no patient is under DLT observation period at the beginning;
    preSize <- 0

    ## inside this loop we continue filling up the table, until
    ## stopping
    while (!stopit) {
      ## what is the cohort size at this dose?
      thisSize <- size(object@cohort_size, dose = thisDose, data = baseData)

      ## what's the safetywindow
      thisSafetywindow <- windowLength(object@safetyWindow, thisSize)

      # initial parameters
      thisT0 <- trialtime + cumsum(thisSafetywindow$patientGap)

      factDLTs <- c(factDLTs, rep(0, thisSize))

      factSurv <- c(factSurv, rep(Tmax, thisSize))

      factT0 <- c(factT0, thisT0)

      ## The time that the next cohort open
      trialtime <- trialtime +
        nextOpen(
          window = thisSafetywindow,
          thisSurv = rep(Tmax, thisSize)
        )

      ## In the DA-CRM, we should count the number of patients who is still within the DLT window;
      ## Thus the loop for numDLTs should be 0:nFollow;
      nFollow <- thisSize + preSize

      ## Identify the censored patients;
      ## "thiscensored" will be used in the cases that numDLTs>0;
      npt <- length(baseData@x) # total number of patients

      thiscensored <- c(
        c(1:npt)[(trialtime - baseData@t0) < baseData@Tmax & baseData@y == 0],
        (npt + 1):(npt + thisSize)
      )

      ## for all possible number of DLTs:
      for (numDLTs in 0:nFollow) {
        ## If numDLTs>0, two extreme cases will be examinated;
        ## (1) DLTs occur on patients with the longer follow ups;
        ## (2) DLTs occur on patients with the shorter follow ups;

        if (numDLTs == 0) {
          baseData <- update(
            object = baseData,
            y = factDLTs, #### the x will be constantly updated according to u
            u = factSurv,
            t0 = factT0,
            x = thisDose,
            trialtime = trialtime
          ) #### the u will be constantly updated

          ## what is the dose limit?
          doselimit <- maxDose(object@increments, data = baseData)

          ## generate samples from the model
          thisSamples <- mcmc(
            data = baseData,
            model = object@model,
            options = mcmcOptions
          )

          ## => what is the next best dose?
          nextDose <- nextBest(
            object@nextBest,
            doselimit = doselimit,
            samples = thisSamples,
            model = object@model,
            data = baseData
          )$value

          # ##remove savePlot
          #
          #                                                   savePlot(plot(baseData),name=paste("Dose",thisDose,0,"DLT",nextDose,sep="_"))
          #
          ## compute relative increment in percent
          thisIncrement <-
            round((nextDose - thisDose) / thisDose * 100)

          ## evaluate stopping rules
          stopThisTrial <- stopTrial(
            object@stopping,
            dose = nextDose,
            samples = thisSamples,
            model = object@model,
            data = baseData
          )

          ## append information to the data frame
          ret <- rbind(
            ret,
            list(
              DLTsearly_1 = 0,
              dose = thisDose,
              DLTs = numDLTs,
              nextDose = nextDose,
              stop = stopThisTrial,
              increment = as.integer(thisIncrement)
            )
          )
          ### comment here to show only no DLTs;
          #                                            }
        } else {
          for (DLTsearly in 1:numDLTs) {
            # Update current {fact} variables
            thisDLTs <- factDLTs
            thisSurv <- factSurv

            if (DLTsearly == 1) {
              # scenario 1: The patients with longest follow up have DLTs

              thisDLTs[thiscensored][1:numDLTs] <- rep(1, rep(numDLTs))

              thisSurv[thiscensored][1:numDLTs] <- apply(
                rbind(
                  rep(Tmax, numDLTs),
                  c(trialtime - factT0[thiscensored][1:numDLTs])
                ),
                2,
                min
              )

              thisData <- update(
                object = baseData,
                y = thisDLTs, #### the y will be updated according to u
                u = thisSurv,
                t0 = factT0,
                x = thisDose,
                trialtime = trialtime
              ) #### the u will be updated
            } else {
              # scenario 2: The patients with shortest follow up have DLTs

              thisDLTs[rev(thiscensored)][1:numDLTs] <- rep(1, rep(numDLTs))

              thisSurv[rev(thiscensored)][1:numDLTs] <- c(apply(
                rbind(
                  rep(1, numDLTs),
                  pretime + 1 - factT0[rev(thiscensored)][1:numDLTs]
                ),
                2,
                max
              ))

              if (numDLTs >= thisSize) {
                thistime <- 1 + max(thisT0)
              } else {
                thistime <- trialtime
              }

              thisData <- update(
                object = baseData,
                y = thisDLTs, #### the y will be updated according to u
                u = thisSurv,
                t0 = factT0,
                x = thisDose,
                trialtime = thistime
              ) #### the u will be updated
            }

            ## what is the dose limit?
            doselimit <- maxDose(object@increments, data = thisData)

            ## generate samples from the model
            thisSamples <- mcmc(
              data = thisData,
              model = object@model,
              options = mcmcOptions
            )

            ## => what is the next best dose?
            nextDose <- nextBest(
              object@nextBest,
              doselimit = doselimit,
              samples = thisSamples,
              model = object@model,
              data = thisData
            )$value

            # ##remove savePlot
            #                                                   savePlot(plot(thisData),name=paste("Dose",thisDose,numDLTs,"DLT",DLTsearly,nextDose,sep="_"))
            #
            ## compute relative increment in percent
            thisIncrement <-
              round((nextDose - thisDose) / thisDose * 100)

            ## evaluate stopping rules
            stopThisTrial <- stopTrial(
              object@stopping,
              dose = nextDose,
              samples = thisSamples,
              model = object@model,
              data = thisData
            )

            ## append information to the data frame
            ret <- rbind(
              ret,
              list(
                DLTsearly_1 = DLTsearly,
                dose = thisDose,
                DLTs = numDLTs,
                nextDose = nextDose,
                stop = stopThisTrial,
                increment = as.integer(thisIncrement)
              )
            )
          }
        }
      }

      ## update pretime
      pretime <- trialtime

      ## what are the results if 0 DLTs?
      resultsNoDLTs <- subset(
        ret,
        dose == thisDose & DLTs == 0
      )

      ## what is the new dose according to table?
      newDose <- as.numeric(resultsNoDLTs$nextDose)

      ## what is the difference to the previous dose?
      doseDiff <- newDose - thisDose

      ## would stopping rule be fulfilled already?
      stopAlready <- any(resultsNoDLTs$stop)

      ## update dose
      thisDose <- max(newDose)

      ## number of patients with un-completed DLT window;
      preSize <- sum(baseData@u[baseData@y == 0] < baseData@Tmax)

      ## update the counter for no increments of the dose
      if (all(doseDiff == 0)) {
        noIncrementCounter <- noIncrementCounter + 1L
      } else {
        noIncrementCounter <- 0L
      }

      ## too many times no increment?
      stopNoIncrement <- (noIncrementCounter >= maxNoIncrement)
      if (stopNoIncrement) {
        warning(paste(
          "Stopping because",
          noIncrementCounter,
          "times no increment vs. previous dose"
        ))
      }

      ## check if we can stop:
      ## either when we have reached the highest dose in the
      ## next cohort, or when the stopping rule is already
      ## fulfilled, or when too many times no increment
      stopit <- (thisDose >= max(object@data@doseGrid)) ||
        stopAlready ||
        stopNoIncrement
    }

    return(ret)
  }
)

## ===================================================================================
## ----------------------------------------------------------------------------------------
##  Simulate design using DLE responses only with DLE samples (pseudo DLE model)
## ------------------------------------------------------------------------------------
##' This is a methods to simulate dose escalation procedure only using the DLE responses.
##' This is a method based on the \code{\linkS4class{TDsamplesDesign}} where model used are of
##' \code{\linkS4class{ModelTox}} class object DLE samples are also used
##'
##' @param object the \code{\linkS4class{TDsamplesDesign}} object we want to simulate the data from
##' @param nsim the number of simulations (default :1)
##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param args data frame with arguments for the \code{truth} function. The
##' column names correspond to the argument names, the rows to the values of the
##' arguments. The rows are appropriately recycled in the \code{nsim}
##' simulations. In order to produce outcomes from the posterior predictive
##' distribution, e.g, pass an \code{object} that contains the data observed so
##' far, \code{truth} contains the \code{prob} function from the model in
##' \code{object}, and \code{args} contains posterior samples from the model.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##'
##' @example examples/design-method-simulateTDsamplesDesign.R
##'
##' @return an object of class \code{\linkS4class{PseudoSimulations}}
##'
##'  @export
##'  @keywords methods
setMethod(
  "simulate",
  signature = signature(
    object = "TDsamplesDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  def = function(
    object,
    nsim = 1L,
    seed = NULL,
    truth,
    args = NULL,
    firstSeparate = FALSE,
    mcmcOptions = McmcOptions(),
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5L),
    ...
  ) {
    ## checks and extracts
    assert_function(truth)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    args <- as.data.frame(args)
    nArgs <- max(nrow(args), 1L)

    ## seed handling
    RNGstate <- set_seed(seed)

    ## from this,
    ## generate the individual seeds for the simulation runs
    simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

    ## the function to produce the run a single simulation
    ## with index "iterSim"
    runSim <- function(iterSim) {
      ## set the seed for this run
      set.seed(simSeeds[iterSim])

      ## what is now the argument for the truth?
      ## (appropriately recycled)
      thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

      ## so this truth is...
      thisTruth <- function(dose) {
        do.call(
          truth,
          ## First argument: the dose
          c(
            dose,
            ## Following arguments
            thisArgs
          )
        )
      }

      ## start the simulated data with the provided one
      thisData <- object@data

      # In case there are placebo
      if (thisData@placebo) {
        ## what is the probability for tox. at placebo?
        thisProb.PL <- thisTruth(object@data@doseGrid[1])
      }

      ## shall we stop the trial?
      ## First, we want to continue with the starting dose.
      ## This variable is updated after each cohort in the loop.
      stopit <- FALSE

      ## what is the next dose to be used?
      ## initialize with starting dose
      thisDose <- object@startingDose

      ## inside this loop we simulate the whole trial, until stopping
      while (!stopit) {
        ## what is the probability for tox. at this dose?
        thisProb <- thisTruth(thisDose)

        ## what is the cohort size at this dose?
        thisSize <- size(object@cohort_size, dose = thisDose, data = thisData)

        ## In case there are placebo
        if (thisData@placebo) {
          thisSize.PL <- size(
            object@pl_cohort_size,
            dose = thisDose,
            data = thisData
          )
        }

        ## simulate DLTs: depends on whether we
        ## separate the first patient or not.
        if (firstSeparate && (thisSize > 1L)) {
          ## dose the first patient
          thisDLTs <- rbinom(
            n = 1L,
            size = 1L,
            prob = thisProb
          )

          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisDLTs.PL <- rbinom(
              n = 1L,
              size = 1L,
              prob = thisProb.PL
            )
          }

          ## if there is no DLT:
          if (thisDLTs == 0) {
            ## enroll the remaining patients
            thisDLTs <- c(
              thisDLTs,
              rbinom(
                n = thisSize - 1L,
                size = 1L,
                prob = thisProb
              )
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- c(
                thisDLTs.PL,
                rbinom(
                  n = thisSize.PL,
                  size = 1L,
                  prob = thisProb.PL
                )
              )
            }
          }
        } else {
          ## we can directly dose all patients
          thisDLTs <- rbinom(
            n = thisSize,
            size = 1L,
            prob = thisProb
          )
          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisDLTs.PL <- rbinom(
              n = thisSize.PL,
              size = 1L,
              prob = thisProb.PL
            )
          }
        }

        ## update the data with this placebo (if any) cohort and then with active dose
        if (thisData@placebo && (thisSize.PL > 0L)) {
          thisData <- update(
            object = thisData,
            x = object@data@doseGrid[1],
            y = thisDLTs.PL
          )

          ## update the data with active dose
          thisData <- update(
            object = thisData,
            x = thisDose,
            y = thisDLTs,
            new_cohort = FALSE
          )
        } else {
          ## update the data with this cohort
          thisData <- update(
            object = thisData,
            x = thisDose,
            y = thisDLTs
          )
        }

        ## Update the model with thisData
        thisModel <- update(object@model, data = thisData)

        ## what is the dose limit?
        doselimit <- maxDose(object@increments, data = thisData)

        ## generate samples from the model
        thisSamples <- mcmc(
          data = thisData,
          model = thisModel,
          options = mcmcOptions
        )

        ## => what is the next best dose?

        next_bd <- nextBest(
          object@nextBest,
          doselimit = doselimit,
          samples = thisSamples,
          model = thisModel,
          data = thisData,
          in_sim = TRUE
        )

        thisDose <- next_bd$next_dose_drt
        thisTDtargetDuringTrial <- next_bd$dose_target_drt
        thisTDtargetEndOfTrial <- next_bd$dose_target_eot
        thisTDtargetEndOfTrialatdoseGrid <- next_bd$next_dose_eot
        thisCITDEOT <- list(
          lower = next_bd$ci_dose_target_eot[1],
          upper = next_bd$ci_dose_target_eot[2]
        )
        thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

        ## evaluate stopping rules
        stopit <- stopTrial(
          object@stopping,
          dose = thisDose,
          samples = thisSamples,
          model = thisModel,
          data = thisData
        )
        stopit_results <- h_unpack_stopit(stopit)
      }

      ## get the fit
      thisFit <- fit(
        object = thisSamples,
        model = thisModel,
        data = thisData
      )

      ## return the results
      thisResult <-
        list(
          data = thisData,
          dose = thisDose,
          TDtargetDuringTrial = thisTDtargetDuringTrial,
          TDtargetEndOfTrial = thisTDtargetEndOfTrial,
          TDtargetEndOfTrialatdoseGrid = thisTDtargetEndOfTrialatdoseGrid,
          TDtargetDuringTrialatdoseGrid = thisDose,
          CITDEOT = thisCITDEOT,
          ratioTDEOT = thisratioTDEOT,
          fit = subset(thisFit, select = c(middle, lower, upper)),
          stop = attr(
            stopit,
            "message"
          ),
          report_results = stopit_results
        )
      return(thisResult)
    }

    resultList <- get_result_list(
      fun = runSim,
      nsim = nsim,
      vars = c(
        "simSeeds",
        "args",
        "nArgs",
        "firstSeparate",
        "truth",
        "object",
        "mcmcOptions"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    ## put everything in the Simulations format:

    ## setup the list for the simulated data objects
    dataList <- lapply(resultList, "[[", "data")

    ## set up list for the final TD during Trial Estimate
    TDtargetDuringTrialList <- as.numeric(sapply(
      resultList,
      "[[",
      "TDtargetDuringTrial"
    ))

    ## set up list for the final TD End of Trial Estimate
    TDtargetEndOfTrialList <- as.numeric(sapply(
      resultList,
      "[[",
      "TDtargetEndOfTrial"
    ))

    ## set up list for the final TD during Trial estimate at dose Grid
    TDtargetDuringTrialDoseGridList <- as.numeric(sapply(
      resultList,
      "[[",
      "TDtargetDuringTrialatdoseGrid"
    ))

    ## set up list for the final TD End Of Trial estimate at dose Grid
    TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(
      resultList,
      "[[",
      "TDtargetEndOfTrialatdoseGrid"
    ))

    ## the vector of the final dose recommendations
    recommendedDoses <- as.numeric(sapply(
      resultList,
      "[[",
      "TDtargetEndOfTrialatdoseGrid"
    ))

    ## Set up the list for the final 95% CI obtained
    CIList <- lapply(resultList, "[[", "CITDEOT")

    ## Set up the list for the final ratios obtained
    ratioList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

    ## Set up the list for the final TDEOT 95% CI obtained
    CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

    ## Set up the list for the final TDEOT ratios obtained
    ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

    ## setup the list for the final fits
    fitList <- lapply(resultList, "[[", "fit")

    ## the reasons for stopping
    stopReasons <- lapply(resultList, "[[", "stop")

    # individual stopping rule results as matrix, labels as column names
    stop_results <- lapply(resultList, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))

    ## return the results in the Simulations class object
    ret <- PseudoSimulations(
      data = dataList,
      doses = recommendedDoses,
      fit = fitList,
      final_td_target_during_trial_estimates = TDtargetDuringTrialList,
      final_td_target_end_of_trial_estimates = TDtargetEndOfTrialList,
      final_td_target_during_trial_at_dose_grid = TDtargetDuringTrialDoseGridList,
      final_td_target_end_of_trial_at_dose_grid = TDtargetEndOfTrialDoseGridList,
      final_cis = CIList,
      final_ratios = ratioList,
      final_tdeot_cis = CITDEOTList,
      final_tdeot_ratios = ratioTDEOTList,
      stop_reasons = stopReasons,
      stop_report = stop_report,
      seed = RNGstate
    )

    return(ret)
  }
)
## -------------------------------------------------------------------------------------
## Simulate design using DLE responses only without samples (pseudo DLE model)
## --------------------------------------------------------------------------------
###
##' This is a methods to simulate dose escalation procedure only using the DLE responses.
##' This is a method based on the \code{\linkS4class{TDDesign}} where model used are of
##' \code{\linkS4class{ModelTox}} class object and no samples are involved.
##'
##' @param object the \code{\linkS4class{TDDesign}} object we want to simulate the data from
##' @param nsim the number of simulations (default :1)
##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param args data frame with arguments for the \code{truth} function. The
##' column names correspond to the argument names, the rows to the values of the
##' arguments. The rows are appropriately recycled in the \code{nsim}
##' simulations. In order to produce outcomes from the posterior predictive
##' distribution, e.g, pass an \code{object} that contains the data observed so
##' far, \code{truth} contains the \code{prob} function from the model in
##' \code{object}, and \code{args} contains posterior samples from the model.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##'
##' @example examples/design-method-simulateTDDesign.R
##'
##' @return an object of class \code{\linkS4class{PseudoSimulations}}
##'
##'  @export
##'  @keywords methods
setMethod(
  "simulate",
  signature = signature(
    object = "TDDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  def = function(
    object,
    nsim = 1L,
    seed = NULL,
    truth,
    args = NULL,
    firstSeparate = FALSE,
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5L),
    ...
  ) {
    ## checks and extracts
    assert_function(truth)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    args <- as.data.frame(args)
    nArgs <- max(nrow(args), 1L)

    ## seed handling
    RNGstate <- set_seed(seed)

    ## from this,
    ## generate the individual seeds for the simulation runs
    simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

    ## the function to produce the run a single simulation
    ## with index "iterSim"
    runSim <- function(iterSim) {
      ## set the seed for this run
      set.seed(simSeeds[iterSim])

      ## what is now the argument for the truth?
      ## (appropriately recycled)
      thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

      ## so this truth is...
      thisTruth <- function(dose) {
        do.call(
          truth,
          ## First argument: the dose
          c(
            dose,
            ## Following arguments
            thisArgs
          )
        )
      }

      ## start the simulated data with the provided one
      thisData <- object@data

      # In case there are placebo
      if (thisData@placebo) {
        ## what is the probability for tox. at placebo?
        thisProb.PL <- thisTruth(object@data@doseGrid[1])
      }

      ## shall we stop the trial?
      ## First, we want to continue with the starting dose.
      ## This variable is updated after each cohort in the loop.
      stopit <- FALSE

      ## what is the next dose to be used?
      ## initialize with starting dose
      thisDose <- object@startingDose

      ## inside this loop we simulate the whole trial, until stopping
      while (!stopit) {
        ## what is the probability for tox. at this dose?
        thisProb <- thisTruth(thisDose)

        ## what is the cohort size at this dose?
        thisSize <- size(object@cohort_size, dose = thisDose, data = thisData)

        ## In case there are placebo
        if (thisData@placebo) {
          thisSize.PL <- size(
            object@pl_cohort_size,
            dose = thisDose,
            data = thisData
          )
        }

        ## simulate DLTs: depends on whether we
        ## separate the first patient or not.
        if (firstSeparate && (thisSize > 1L)) {
          ## dose the first patient
          thisDLTs <- rbinom(
            n = 1L,
            size = 1L,
            prob = thisProb
          )

          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisDLTs.PL <- rbinom(
              n = 1L,
              size = 1L,
              prob = thisProb.PL
            )
          }

          ## if there is no DLT:
          if (thisDLTs == 0) {
            ## enroll the remaining patients
            thisDLTs <- c(
              thisDLTs,
              rbinom(
                n = thisSize - 1L,
                size = 1L,
                prob = thisProb
              )
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- c(
                thisDLTs.PL,
                rbinom(
                  n = thisSize.PL,
                  size = 1L,
                  prob = thisProb.PL
                )
              )
            }
          }
        } else {
          ## we can directly dose all patients
          thisDLTs <- rbinom(
            n = thisSize,
            size = 1L,
            prob = thisProb
          )

          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisDLTs.PL <- rbinom(
              n = thisSize.PL,
              size = 1L,
              prob = thisProb.PL
            )
          }
        }

        ## update the data with this placebo (if any) cohort and then with active dose
        if (thisData@placebo && (thisSize.PL > 0L)) {
          thisData <- update(
            object = thisData,
            x = object@data@doseGrid[1],
            y = thisDLTs.PL
          )

          ## update the data with active dose
          thisData <- update(
            object = thisData,
            x = thisDose,
            y = thisDLTs,
            new_cohort = FALSE
          )
        } else {
          ## update the data with this cohort
          thisData <- update(
            object = thisData,
            x = thisDose,
            y = thisDLTs
          )
        }

        ## Update model estimates with thisData
        thisModel <- update(object@model, data = thisData)

        ## what is the dose limit?
        doselimit <- maxDose(object@increments, data = thisData)

        ## => what is the next best dose?
        next_bd <- nextBest(
          object@nextBest,
          doselimit = doselimit,
          model = thisModel,
          data = thisData,
          in_sim = TRUE
        )

        thisDose <- next_bd$next_dose_drt
        thisTDtargetDuringTrial <- next_bd$dose_target_drt
        thisTDtargetEndOfTrial <- next_bd$dose_target_eot
        thisTDtargetEndOfTrialatdoseGrid <- next_bd$next_dose_eot
        thisCITDEOT <- list(
          lower = next_bd$ci_dose_target_eot[1],
          upper = next_bd$ci_dose_target_eot[2]
        )
        thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

        ## evaluate stopping rules
        stopit <- stopTrial(
          object@stopping,
          dose = thisDose,
          model = thisModel,
          data = thisData
        )
        stopit_results <- h_unpack_stopit(stopit)
      }
      ## get the fit
      prob_fun <- probFunction(
        thisModel,
        phi1 = thisModel@phi1,
        phi2 = thisModel@phi2
      )
      thisFit <- list(
        phi1 = thisModel@phi1,
        phi2 = thisModel@phi2,
        probDLE = prob_fun(object@data@doseGrid)
      )

      ## return the results
      thisResult <-
        list(
          data = thisData,
          dose = thisDose,
          TDtargetDuringTrial = thisTDtargetDuringTrial,
          TDtargetEndOfTrial = thisTDtargetEndOfTrial,
          TDtargetEndOfTrialatdoseGrid = thisTDtargetEndOfTrialatdoseGrid,
          TDtargetDuringTrialatdoseGrid = thisDose,
          CITDEOT = thisCITDEOT,
          ratioTDEOT = thisratioTDEOT,
          fit = thisFit,
          stop = attr(
            stopit,
            "message"
          ),
          report_results = stopit_results
        )
      return(thisResult)
    }

    resultList <- get_result_list(
      fun = runSim,
      nsim = nsim,
      vars = c(
        "simSeeds",
        "args",
        "nArgs",
        "firstSeparate",
        "truth",
        "object"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    ## put everything in the Simulations format:

    ## setup the list for the simulated data objects
    dataList <- lapply(resultList, "[[", "data")

    ## set up list for the final TD during Trial Estimate
    TDtargetDuringTrialList <- as.numeric(sapply(
      resultList,
      "[[",
      "TDtargetDuringTrial"
    ))

    ## set up list for the final TD End of Trial Estimate
    TDtargetEndOfTrialList <- as.numeric(sapply(
      resultList,
      "[[",
      "TDtargetEndOfTrial"
    ))

    ## set up list for the final TD during Trial estimate at dose Grid
    TDtargetDuringTrialDoseGridList <- as.numeric(sapply(
      resultList,
      "[[",
      "TDtargetDuringTrialatdoseGrid"
    ))

    ## set up list for the final TD End Of Trial estimate at dose Grid
    TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(
      resultList,
      "[[",
      "TDtargetEndOfTrialatdoseGrid"
    ))

    ## the vector of the final dose recommendations
    recommendedDoses <- as.numeric(sapply(
      resultList,
      "[[",
      "TDtargetEndOfTrialatdoseGrid"
    ))

    ## Set up the list for the final 95% CI obtained
    CIList <- lapply(resultList, "[[", "CITDEOT")

    ## Set up the list for the final ratios obtained
    ratioList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

    ## Set up the list for the final TDEOT 95% CI obtained
    CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

    ## Set up the list for the final TDEOT ratios obtained
    ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))
    ## set up the list for the final fits

    fitList <- lapply(resultList, "[[", "fit")

    ## the reasons for stopping
    stopReasons <- lapply(resultList, "[[", "stop")

    # individual stopping rule results as matrix, labels as column names
    stop_results <- lapply(resultList, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))

    ## return the results in the Simulations class object
    ret <- PseudoSimulations(
      data = dataList,
      doses = recommendedDoses,
      fit = fitList,
      final_td_target_during_trial_estimates = TDtargetDuringTrialList,
      final_td_target_end_of_trial_estimates = TDtargetEndOfTrialList,
      final_td_target_during_trial_at_dose_grid = TDtargetDuringTrialDoseGridList,
      final_td_target_end_of_trial_at_dose_grid = TDtargetEndOfTrialDoseGridList,
      final_cis = CIList,
      final_ratios = ratioList,
      final_tdeot_cis = CITDEOTList,
      final_tdeot_ratios = ratioTDEOTList,
      stop_reasons = stopReasons,
      stop_report = stop_report,
      seed = RNGstate
    )

    return(ret)
  }
)
## -----------------------------------------------------------------------------------------------
## Simulate design using DLE and efficacy responses without DLE and efficacy samples (pseudo models)
## --------------------------------------------------------------------------------------------
###
##' This is a methods to simulate dose escalation procedure using both DLE and efficacy responses.
##' This is a method based on the \code{\linkS4class{DualResponsesDesign}} where DLEmodel used are of
##' \code{\linkS4class{ModelTox}} class object and efficacy model used are of \code{\linkS4class{ModelEff}}
##' class object. In addition, no DLE and efficacy samples are involved or generated in the simulation
##' process
##'
##' @param object the \code{\linkS4class{DualResponsesDesign}} object we want to simulate the data from
##' @param nsim the number of simulations (default :1)
##' @param seed see \code{\link{set_seed}}
##' @param trueDLE a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param trueEff a function which takes as input a dose (vector) and returns the expected efficacy
##' responses (vector). Additional arguments can be supplied in \code{args}.
##' @param trueNu the precision, the inverse of the variance of the efficacy responses
##' @param args data frame with arguments for the \code{trueDLE} and
##' \code{trueEff} function. The column names correspond to the argument
##' names, the rows to the values of the arguments. The rows are appropriately
##' recycled in the \code{nsim} simulations.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##'
##' @example examples/design-method-simulateDualResponsesDesign.R
##'
##' @return an object of class \code{\linkS4class{PseudoDualSimulations}}
##'
##' @export
##' @keywords methods

setMethod(
  "simulate",
  signature = signature(
    object = "DualResponsesDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  def = function(
    object,
    nsim = 1L,
    seed = NULL,
    trueDLE,
    trueEff,
    trueNu,
    args = NULL,
    firstSeparate = FALSE,
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5L),
    ...
  ) {
    ## checks and extracts
    assert_function(trueDLE)
    assert_function(trueEff)
    assert_true(trueNu > 0)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    args <- as.data.frame(args)
    nArgs <- max(nrow(args), 1L)

    ## get names of arguments (excluding the first one which is the dose)
    trueDLEArgnames <- names(formals(trueDLE))[-1]
    trueEffArgnames <- names(formals(trueEff))[-1]

    ## seed handling
    RNGstate <- set_seed(seed)

    ## from this,
    ## generate the individual seeds for the simulation runs
    simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

    ## the function to produce the run a single simulation
    ## with index "iterSim"
    runSim <- function(iterSim) {
      ## set the seed for this run
      set.seed(simSeeds[iterSim])

      ## what is now the argument for the truth?
      ## (appropriately recycled)
      thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

      ## so this truth DLE function is...
      thisTruthDLE <- function(dose) {
        do.call(
          trueDLE,
          ## First argument: the dose
          c(
            dose,
            ## Following arguments: take only those that
            ## are required by the DLE function
            as.list(thisArgs)[trueDLEArgnames]
          )
        )
      }

      ## and the truth Eff function is:
      thisTruthEff <- function(dose) {
        do.call(
          trueEff,
          ## First argument: the dose
          c(
            dose,
            ## Following arguments: take only those that
            ## are required by the Eff function
            as.list(thisArgs)[trueEffArgnames]
          )
        )
      }

      ## start the simulated data with the provided one
      thisData <- object@data

      ## find true sigma2 to generate responses

      trueSigma2 <- 1 / trueNu

      ## start the simulated data with the provided one
      thisData <- object@data

      if (thisData@placebo) {
        ## what is the probability for tox. at placebo?
        thisProb.PL <- thisTruthDLE(object@data@doseGrid[1])

        ## what is the mean efficacy at placebo?
        thisMeanEff.PL <- thisTruthEff(object@data@doseGrid[1])
      }

      ## shall we stop the trial?
      ## First, we want to continue with the starting dose.
      ## This variable is updated after each cohort in the loop.
      stopit <- FALSE

      ## what is the next dose to be used?
      ## initialize with starting dose
      thisDose <- object@startingDose

      ## inside this loop we simulate the whole trial, until stopping
      while (!stopit) {
        ## what is the probability for tox. at this dose?
        thisDLEProb <- thisTruthDLE(thisDose)
        thisMeanEff <- thisTruthEff(thisDose)

        ## what is the cohort size at this dose?
        thisSize <- size(object@cohort_size, dose = thisDose, data = thisData)

        ## In case there are placebo
        ## what is the cohort size at this dose for Placebo?
        if (thisData@placebo) {
          thisSize.PL <- size(
            object@pl_cohort_size,
            dose = thisDose,
            data = thisData
          )
        }

        ## simulate DLTs: depends on whether we
        ## separate the first patient or not.
        if (firstSeparate && (thisSize > 1L)) {
          ## dose the first patient
          thisDLTs <- rbinom(
            n = 1L,
            size = 1L,
            prob = thisDLEProb
          )

          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisDLTs.PL <- rbinom(
              n = 1L,
              size = 1L,
              prob = thisProb.PL
            )
          }

          thisEff <- rnorm(
            n = 1L,
            mean = thisMeanEff,
            sd = sqrt(trueSigma2)
          )

          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisEff.PL <- rnorm(
              n = 1L,
              mean = thisMeanEff.PL,
              sd = sqrt(trueSigma2)
            )
          }

          ## if there is no DLT:
          if (thisDLTs == 0) {
            ## enroll the remaining patients
            thisDLTs <- c(
              thisDLTs,
              rbinom(
                n = thisSize - 1L,
                size = 1L,
                prob = thisDLEProb
              )
            )

            thisEff <- c(
              thisEff,
              rnorm(
                n = thisSize - 1L,
                mean = thisMeanEff,
                sd = sqrt(trueSigma2)
              )
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- c(
                thisDLTs.PL,
                rbinom(
                  n = thisSize.PL,
                  size = 1L,
                  prob = thisProb.PL
                )
              )
              thisEff.PL <- c(
                thisMeanEff.PL,
                rnorm(
                  n = thisSize.PL,
                  mean = thisMeanEff.PL,
                  sd = sqrt(trueSigma2)
                )
              )
            }
          }
        } else {
          ## we can directly dose all patients
          thisDLTs <- rbinom(
            n = thisSize,
            size = 1L,
            prob = thisDLEProb
          )
          thisEff <- rnorm(
            n = thisSize,
            mean = thisMeanEff,
            sd = sqrt(trueSigma2)
          )

          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisDLTs.PL <- rbinom(
              n = thisSize.PL,
              size = 1L,
              prob = thisProb.PL
            )
            thisEff.PL <- rnorm(
              n = thisSize.PL,
              mean = thisMeanEff.PL,
              sd = sqrt(trueSigma2)
            )
          }
        }

        ## update the data with this placebo (if any) cohort and then with active dose
        if (thisData@placebo && (thisSize.PL > 0L)) {
          thisData <- update(
            object = thisData,
            x = object@data@doseGrid[1],
            y = thisDLTs.PL,
            w = thisEff.PL,
            check = FALSE
          )

          ## update the data with active dose
          thisData <- update(
            object = thisData,
            x = thisDose,
            y = thisDLTs,
            w = thisEff,
            new_cohort = FALSE
          )
        } else {
          ## update the data with this cohort
          thisData <- update(
            object = thisData,
            x = thisDose,
            y = thisDLTs,
            w = thisEff
          )
        }
        ## Update model estimate in DLE and Eff models
        thisDLEModel <- update(
          object = object@model,
          data = thisData
        )

        thisEffModel <- update(
          object = object@eff_model,
          data = thisData
        )

        thisNu <- thisEffModel@nu

        thisSigma2 <- if (thisEffModel@use_fixed) {
          1 / thisNu
        } else {
          1 / (as.numeric(thisNu["a"] / thisNu["b"]))
        }

        ## what is the dose limit?
        doselimit <- maxDose(object@increments, data = thisData)

        ## => what is the next best dose?
        next_bd <- nextBest(
          object@nextBest,
          doselimit = doselimit,
          model = thisDLEModel,
          data = thisData,
          model_eff = thisEffModel,
          in_sim = TRUE
        )

        thisDose <- next_bd$next_dose
        thisTDtargetDuringTrial <- next_bd$dose_target_drt
        thisTDtargetDuringTrialAtDoseGrid <- next_bd$next_dose_drt
        thisTDtargetEndOfTrial <- next_bd$dose_target_eot
        thisTDtargetEndOfTrialAtDoseGrid <- next_bd$next_dose_eot
        thisGstar <- next_bd$dose_max_gain
        thisGstarAtDoseGrid <- next_bd$next_dose_max_gain

        Recommend <- min(thisTDtargetEndOfTrialAtDoseGrid, thisGstarAtDoseGrid)

        ## Find the 95 % CI and its ratio (upper to the lower of this 95% CI of each of the estimates)
        thisCITDEOT <- list(
          lower = next_bd$ci_dose_target_eot[1],
          upper = next_bd$ci_dose_target_eot[2]
        )
        thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

        thisCIGstar <- list(
          lower = next_bd$ci_dose_max_gain[1],
          upper = next_bd$ci_dose_max_gain[2]
        )
        thisratioGstar <- next_bd$ci_ratio_dose_max_gain

        ## Find the optimal dose
        OptimalDose <- min(thisGstar, thisTDtargetEndOfTrial)

        if (OptimalDose == thisGstar) {
          thisratio <- thisratioGstar
          thisCI <- thisCIGstar
        } else {
          thisratio <- thisratioTDEOT
          thisCI <- thisCITDEOT
        }

        ## evaluate stopping rules
        stopit <- stopTrial(
          object@stopping,
          dose = thisDose,
          model = thisDLEModel,
          data = thisData,
          Effmodel = thisEffModel
        )
        stopit_results <- h_unpack_stopit(stopit)
      }

      ## get the fits
      prob_fun <- probFunction(
        thisDLEModel,
        phi1 = thisDLEModel@phi1,
        phi2 = thisDLEModel@phi2
      )
      thisDLEFit <- list(
        phi1 = thisDLEModel@phi1,
        phi2 = thisDLEModel@phi2,
        probDLE = prob_fun(object@data@doseGrid)
      )

      eff_fun <- efficacyFunction(
        thisEffModel,
        theta1 = thisEffModel@theta1,
        theta2 = thisEffModel@theta2
      )
      thisEffFit <- list(
        theta1 = thisEffModel@theta1,
        theta2 = thisEffModel@theta2,
        ExpEff = eff_fun(object@data@doseGrid)
      )

      ## return the results
      thisResult <- list(
        data = thisData,
        dose = thisDose,
        TDtargetDuringTrial = thisTDtargetDuringTrial,
        TDtargetDuringTrialAtDoseGrid = thisTDtargetDuringTrialAtDoseGrid,
        TDtargetEndOfTrial = thisTDtargetEndOfTrial,
        TDtargetEndOfTrialAtDoseGrid = thisTDtargetEndOfTrialAtDoseGrid,
        Gstar = thisGstar,
        GstarAtDoseGrid = thisGstarAtDoseGrid,
        Recommend = Recommend,
        OptimalDose = OptimalDose,
        OptimalDoseAtDoseGrid = Recommend,
        ratio = thisratio,
        CI = thisCI,
        ratioGstar = thisratioGstar,
        CIGstar = thisCIGstar,
        ratioTDEOT = thisratioTDEOT,
        CITDEOT = thisCITDEOT,
        fitDLE = thisDLEFit,
        fitEff = thisEffFit,
        sigma2est = thisSigma2,
        stop = attr(
          stopit,
          "message"
        ),
        report_results = stopit_results
      )

      return(thisResult)
    }

    resultList <- get_result_list(
      fun = runSim,
      nsim = nsim,
      vars = c(
        "simSeeds",
        "args",
        "nArgs",
        "firstSeparate",
        "trueDLE",
        "trueEff",
        "trueNu",
        "object"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    ## put everything in the Simulations format:

    ## setup the list for the simulated data objects
    dataList <- lapply(resultList, "[[", "data")

    ## the vector of the final dose recommendations
    recommendedDoses <- as.numeric(sapply(resultList, "[[", "Recommend"))

    ## set up list for the final TD during Trial Estimate
    TDtargetDuringTrialList <- as.numeric(sapply(
      resultList,
      "[[",
      "TDtargetDuringTrial"
    ))

    ## set up list for the final TD End of Trial Estimate
    TDtargetEndOfTrialList <- as.numeric(sapply(
      resultList,
      "[[",
      "TDtargetEndOfTrial"
    ))

    ## set up list for the final TD during Trial estimate at dose Grid
    TDtargetDuringTrialDoseGridList <- as.numeric(sapply(
      resultList,
      "[[",
      "TDtargetDuringTrialAtDoseGrid"
    ))

    ## set up list for the final TD End Of Trial estimate at dose Grid
    TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(
      resultList,
      "[[",
      "TDtargetEndOfTrialAtDoseGrid"
    ))

    ## set up list for the final Gstar estimates
    GstarList <- as.numeric(sapply(resultList, "[[", "Gstar"))

    ## set up list for the final Gstar estimates at dose grid
    GstarAtDoseGridList <- as.numeric(sapply(
      resultList,
      "[[",
      "GstarAtDoseGrid"
    ))

    ## set up list for final optimal dose estimates
    OptimalDoseList <- as.numeric(sapply(resultList, "[[", "OptimalDose"))

    ## set up list for final optimal dose estimates at dose Grid
    OptimalDoseAtDoseGridList <- as.numeric(sapply(
      resultList,
      "[[",
      "Recommend"
    ))

    ## Set up the list for the final 95% CI obtained
    CIList <- lapply(resultList, "[[", "CI")

    ## Set up the list for the final ratios obtained
    ratioList <- as.numeric(sapply(resultList, "[[", "ratio"))

    ## Set up the list for the final 95% CI of the TDtarget End Of Trial obtained
    CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

    ## Set up the list for the final ratios of the TDtarget End Of Trial obtained
    ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

    ## Set up the list for the final 95% CI of the Gstar obtained
    CIGstarList <- lapply(resultList, "[[", "CIGstar")

    ## Set up the list for the final ratios of the Gstar obtained
    ratioGstarList <- as.numeric(sapply(resultList, "[[", "ratioGstar"))

    ## set up the list for the final fits
    fitDLEList <- lapply(resultList, "[[", "fitDLE")
    fitEffList <- lapply(resultList, "[[", "fitEff")

    ## the vector of the sigma2
    sigma2Estimates <- as.numeric(sapply(resultList, "[[", "sigma2est"))

    ## the reasons for stopping
    stopReasons <- lapply(resultList, "[[", "stop")

    # individual stopping rule results as matrix, labels as column names
    stop_results <- lapply(resultList, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))

    ## return the results in the Simulations class object
    ret <- PseudoDualSimulations(
      data = dataList,
      doses = recommendedDoses,
      final_td_target_during_trial_estimates = TDtargetDuringTrialList,
      final_td_target_end_of_trial_estimates = TDtargetEndOfTrialList,
      final_td_target_during_trial_at_dose_grid = TDtargetDuringTrialDoseGridList,
      final_td_target_end_of_trial_at_dose_grid = TDtargetEndOfTrialDoseGridList,
      final_cis = CIList,
      final_ratios = ratioList,
      final_gstar_estimates = GstarList,
      final_gstar_at_dose_grid = GstarAtDoseGridList,
      final_gstar_cis = CIGstarList,
      final_gstar_ratios = ratioGstarList,
      final_tdeot_cis = CITDEOTList,
      final_tdeot_ratios = ratioTDEOTList,
      final_optimal_dose = OptimalDoseList,
      final_optimal_dose_at_dose_grid = OptimalDoseAtDoseGridList,
      fit = fitDLEList,
      fit_eff = fitEffList,
      sigma2_est = sigma2Estimates,
      stop_reasons = stopReasons,
      stop_report = stop_report,
      seed = RNGstate
    )
    return(ret)
  }
)

## =========================================================================
## -----------------------------------------------------------------------------------------------
## Simulate design using DLE and efficacy responses with DLE and efficacy samples (pseudo models)
## --------------------------------------------------------------------------------------------
###
##' This is a methods to simulate dose escalation procedure using both DLE and efficacy responses.
##' This is a method based on the \code{\linkS4class{DualResponsesSamplesDesign}} where DLEmodel
##' used are of
##' \code{\linkS4class{ModelTox}} class object and efficacy model used are of
##' \code{\linkS4class{ModelEff}}
##' class object (special case is \code{\linkS4class{EffFlexi}} class model object).
##' In addition, DLE and efficacy samples are involved or generated in the simulation
##' process
##'
##' @param object the \code{\linkS4class{DualResponsesSamplesDesign}} object we want to
##' simulate the data from
##' @param nsim the number of simulations (default :1)
##' @param seed see \code{\link{set_seed}}
##' @param trueDLE a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param trueEff a function which takes as input a dose (vector) and returns the expected
##' efficacy responses (vector). Additional arguments can be supplied in \code{args}.
##' @param trueNu (not with \code{\linkS4class{EffFlexi}}) the precision, the inverse of the
##' variance of the efficacy responses
##' @param trueSigma2 (only with \code{\linkS4class{EffFlexi}}) the true variance of the efficacy
##' responses which must be a single positive scalar.
##' @param trueSigma2betaW (only with \code{\linkS4class{EffFlexi}}) the true variance for the
##' random walk model used for smoothing. This must be a single positive scalar.
##' @param args data frame with arguments for the \code{trueDLE} and
##' \code{trueEff} function. The column names correspond to the argument
##' names, the rows to the values of the arguments. The rows are appropriately
##' recycled in the \code{nsim} simulations.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##'
##' @param ... not used.
##'
##' @example examples/design-method-simulateDualResponsesSamplesDesign.R
##'
##' @return an object of class \code{\linkS4class{PseudoDualSimulations}} or
##' \code{\linkS4class{PseudoDualFlexiSimulations}}
##'
##' @export
##' @keywords methods
setMethod(
  "simulate",
  signature = signature(
    object = "DualResponsesSamplesDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  def = function(
    object,
    nsim = 1L,
    seed = NULL,
    trueDLE,
    trueEff,
    trueNu = NULL,
    trueSigma2 = NULL,
    trueSigma2betaW = NULL,
    args = NULL,
    firstSeparate = FALSE,
    mcmcOptions = McmcOptions(),
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5L),
    ...
  ) {
    ## common checks and extracts
    assert_function(trueDLE)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    ## check if special case applies
    isFlexi <- is(object@eff_model, "EffFlexi")

    ## conditional code from here on:
    if (isFlexi) {
      ## special checks and extracts
      stopifnot(
        trueSigma2 > 0,
        trueSigma2betaW > 0,
        is.numeric(trueEff),
        length(trueEff) == length(object@data@doseGrid)
      )

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)

      ## get names of arguments (excluding the first one which is the dose)
      trueDLEArgnames <- names(formals(trueDLE))[-1]

      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        ## what is now the argument for the truth?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## so this truth is...
        thisTruthDLE <- function(dose) {
          do.call(
            trueDLE,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments
              thisArgs
            )
          )
        }

        ## get the true Eff
        thisTruthEff <- trueEff

        ## start the simulated data with the provided one
        thisData <- object@data

        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        ## Start with specified sigma2 and sigma2betaW
        thisSigma2 <- trueSigma2
        thisSigma2betaW <- trueSigma2betaW

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisDLEProb <- thisTruthDLE(thisDose)
          thisDoseIndex <- which(thisDose == thisData@doseGrid)
          thisMeanEff <- thisTruthEff[thisDoseIndex]

          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size, dose = thisDose, data = thisData)

          if (thisData@placebo) {
            thisSize.PL <- size(
              object@pl_cohort_size,
              dose = thisDose,
              data = thisData
            )
          }

          ## simulate DLTs: depends on whether we
          ## separate the first patient or not.
          if (firstSeparate && (thisSize > 1L)) {
            ## dose the first patient
            thisDLTs <- rbinom(
              n = 1L,
              size = 1L,
              prob = thisDLEProb
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = 1L,
                size = 1L,
                prob = thisProb.PL
              )
            }

            thisEff <- rnorm(
              n = 1L,
              mean = thisMeanEff,
              sd = sqrt(trueSigma2)
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisEff.PL <- rnorm(
                n = 1L,
                mean = thisMeanEff.PL,
                sd = sqrt(trueSigma2)
              )
            }

            ## if there is no DLT:
            if (thisDLTs == 0) {
              ## enroll the remaining patients
              thisDLTs <- c(
                thisDLTs,
                rbinom(
                  n = thisSize - 1L,
                  size = 1L,
                  prob = thisDLEProb
                )
              )
              thisEff <- c(
                thisEff,
                rnorm(
                  n = thisSize - 1L,
                  mean = thisMeanEff,
                  sd = sqrt(trueSigma2)
                )
              )
              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- c(
                  thisDLTs.PL,
                  rbinom(
                    n = thisSize.PL,
                    size = 1L,
                    prob = thisProb.PL
                  )
                )
                thisEff.PL <- c(
                  thisMeanEff.PL,
                  rnorm(
                    n = thisSize.PL,
                    mean = thisMeanEff.PL,
                    sd = sqrt(trueSigma2)
                  )
                )
              }
            }
          } else {
            ## we can directly dose all patients
            thisDLTs <- rbinom(
              n = thisSize,
              size = 1L,
              prob = thisDLEProb
            )

            thisEff <- rnorm(
              n = thisSize,
              mean = thisMeanEff,
              sd = sqrt(trueSigma2)
            )
            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = thisSize.PL,
                size = 1L,
                prob = thisProb.PL
              )
              thisEff.PL <- rnorm(
                n = thisSize.PL,
                mean = thisMeanEff.PL,
                sd = sqrt(trueSigma2)
              )
            }
          }

          ## update the data with this placebo (if any) cohort and then with active dose
          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisData <- update(
              object = thisData,
              x = object@data@doseGrid[1],
              y = thisDLTs.PL,
              w = thisEff.PL,
              check = FALSE
            )

            ## update the data with active dose
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              w = thisEff,
              new_cohort = FALSE
            )
          } else {
            ## update the data with this cohort
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              w = thisEff
            )
          }

          ## Update model estimate in DLE model
          thisDLEModel <- update(
            object = object@model,
            data = thisData
          )

          thisEffModel <- update(
            object = object@eff_model,
            data = thisData
          )

          ## what is the dose limit?
          doselimit <- maxDose(object@increments, data = thisData)

          ## generate DLE and Eff samples from the DLE and Eff model
          thisDLEsamples <- mcmc(
            data = thisData,
            model = thisDLEModel,
            options = mcmcOptions
          )

          thisEffsamples <- mcmc(
            data = thisData,
            model = thisEffModel,
            options = mcmcOptions
          )

          thisSigma2 <- mean(thisEffsamples@data$sigma2W)

          thisSigma2betaW <- mean(thisEffsamples@data$sigma2betaW)

          ## => what is the next best dose?

          next_bd <- nextBest(
            object@nextBest,
            doselimit = doselimit,
            samples = thisDLEsamples,
            model = thisDLEModel,
            model_eff = thisEffModel,
            samples_eff = thisEffsamples,
            data = thisData,
            in_sim = TRUE
          )

          thisDose <- next_bd$next_dose
          thisTDtargetDuringTrial <- next_bd$dose_target_drt
          thisTDtargetDuringTrialAtDoseGrid <- next_bd$next_dose_drt
          thisTDtargetEndOfTrial <- next_bd$dose_target_eot
          thisTDtargetEndOfTrialAtDoseGrid <- next_bd$next_dose_eot
          thisGstar <- next_bd$dose_max_gain
          thisGstarAtDoseGrid <- next_bd$next_dose_max_gain

          Recommend <- min(
            thisTDtargetEndOfTrialAtDoseGrid,
            thisGstarAtDoseGrid
          )

          ## Find the 95 % CI and its ratio (upper to the lower of this 95% CI of each of the estimates)
          thisCITDEOT <- list(
            lower = next_bd$ci_dose_target_eot[1],
            upper = next_bd$ci_dose_target_eot[2]
          )
          thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

          thisCIGstar <- list(
            lower = next_bd$ci_dose_max_gain[1],
            upper = next_bd$ci_dose_max_gain[2]
          )
          thisratioGstar <- next_bd$ci_ratio_dose_max_gain

          ## Find the optimal dose
          OptimalDose <- min(thisGstar, thisTDtargetEndOfTrial)

          if (OptimalDose == thisGstar) {
            thisratio <- thisratioGstar
            thisCI <- thisCIGstar
          } else {
            thisratio <- thisratioTDEOT
            thisCI <- thisCITDEOT
          }

          ## evaluate stopping rules
          stopit <- stopTrial(
            object@stopping,
            dose = thisDose,
            samples = thisDLEsamples,
            model = thisDLEModel,
            data = thisData,
            TDderive = object@nextBest@derive,
            Effmodel = thisEffModel,
            Effsamples = thisEffsamples,
            Gstarderive = object@nextBest@mg_derive
          )
          stopit_results <- h_unpack_stopit(stopit)
        }

        ## get the fits

        thisDLEFit <- fit(
          object = thisDLEsamples,
          model = thisDLEModel,
          data = thisData
        )

        thisEffFit <- fit(
          object = thisEffsamples,
          model = thisEffModel,
          data = thisData
        )

        ## return the results
        thisResult <-
          list(
            data = thisData,
            dose = thisDose,
            TDtargetDuringTrial = thisTDtargetDuringTrial,
            TDtargetDuringTrialAtDoseGrid = thisTDtargetDuringTrialAtDoseGrid,
            TDtargetEndOfTrial = thisTDtargetEndOfTrial,
            TDtargetEndOfTrialAtDoseGrid = thisTDtargetEndOfTrialAtDoseGrid,
            Gstar = thisGstar,
            GstarAtDoseGrid = thisGstarAtDoseGrid,
            Recommend = Recommend,
            OptimalDose = OptimalDose,
            OptimalDoseAtDoseGrid = Recommend,
            ratio = thisratio,
            CI = thisCI,
            ratioGstar = thisratioGstar,
            CIGstar = thisCIGstar,
            ratioTDEOT = thisratioTDEOT,
            CITDEOT = thisCITDEOT,
            fitDLE = subset(thisDLEFit, select = c(middle, lower, upper)),
            fitEff = subset(thisEffFit, select = c(middle, lower, upper)),
            sigma2est = thisSigma2,
            sigma2betaWest = thisSigma2betaW,
            stop = attr(
              stopit,
              "message"
            ),
            report_results = stopit_results
          )

        return(thisResult)
      }

      resultList <- get_result_list(
        fun = runSim,
        nsim = nsim,
        vars = c(
          "simSeeds",
          "args",
          "nArgs",
          "firstSeparate",
          "trueDLE",
          "trueEff",
          "trueSigma2",
          "trueSigma2betaW",
          "object",
          "mcmcOptions"
        ),
        parallel = parallel,
        n_cores = nCores
      )

      ## put everything in the Simulations format:

      ## setup the list for the simulated data objects
      dataList <- lapply(resultList, "[[", "data")

      ## the vector of the final dose recommendations
      recommendedDoses <- as.numeric(sapply(resultList, "[[", "Recommend"))

      ## set up the list for the final fits for both DLE and efficacy
      fitDLEList <- lapply(resultList, "[[", "fitDLE")
      fitEffList <- lapply(resultList, "[[", "fitEff")

      ## the vector of sigma2 estimates
      sigma2Estimates <- as.numeric(sapply(resultList, "[[", "sigma2est"))

      ## the vector of sigma2betaW estimates
      sigma2betaWEstimates <- as.numeric(sapply(
        resultList,
        "[[",
        "sigma2betaWest"
      ))

      ## set up list for the final TD during Trial Estimate
      TDtargetDuringTrialList <- as.numeric(sapply(
        resultList,
        "[[",
        "TDtargetDuringTrial"
      ))

      ## set up list for the final TD End of Trial Estimate
      TDtargetEndOfTrialList <- as.numeric(sapply(
        resultList,
        "[[",
        "TDtargetEndOfTrial"
      ))

      ## set up list for the final TD during Trial estimate at dose Grid
      TDtargetDuringTrialDoseGridList <- as.numeric(sapply(
        resultList,
        "[[",
        "TDtargetDuringTrialAtDoseGrid"
      ))

      ## set up list for the final TD End Of Trial estimate at dose Grid
      TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(
        resultList,
        "[[",
        "TDtargetEndOfTrialAtDoseGrid"
      ))

      ## set up list for the final Gstar estimates
      GstarList <- as.numeric(sapply(resultList, "[[", "Gstar"))

      ## set up list for the final Gstar estimates at dose grid
      GstarAtDoseGridList <- as.numeric(sapply(
        resultList,
        "[[",
        "GstarAtDoseGrid"
      ))

      ## set up list for final optimal dose estimates
      OptimalDoseList <- as.numeric(sapply(resultList, "[[", "OptimalDose"))

      ## set up list for final optimal dose estimates at dose Grid
      OptimalDoseAtDoseGridList <- as.numeric(sapply(
        resultList,
        "[[",
        "Recommend"
      ))

      ## Set up the list for the final 95% CI obtained
      CIList <- lapply(resultList, "[[", "CI")

      ## Set up the list for the final ratios obtained
      ratioList <- as.numeric(sapply(resultList, "[[", "ratio"))

      ## Set up the list for the final 95% CI of the TDtarget End Of Trial obtained
      CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

      ## Set up the list for the final ratios of the TDtarget End Of Trial obtained
      ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

      ## Set up the list for the final 95% CI of the Gstar obtained
      CIGstarList <- lapply(resultList, "[[", "CIGstar")

      ## Set up the list for the final ratios of the Gstar obtained
      ratioGstarList <- as.numeric(sapply(resultList, "[[", "ratioGstar"))

      ## the reasons for stopping
      stopReasons <- lapply(resultList, "[[", "stop")

      # individual stopping rule results as matrix, labels as column names
      stop_results <- lapply(resultList, "[[", "report_results")
      stop_report <- as.matrix(do.call(rbind, stop_results))

      ## return the results in the Simulations class object
      ret <- PseudoDualFlexiSimulations(
        data = dataList,
        doses = recommendedDoses,
        final_td_target_during_trial_estimates = TDtargetDuringTrialList,
        final_td_target_end_of_trial_estimates = TDtargetEndOfTrialList,
        final_td_target_during_trial_at_dose_grid = TDtargetDuringTrialDoseGridList,
        final_td_target_end_of_trial_at_dose_grid = TDtargetEndOfTrialDoseGridList,
        final_cis = CIList,
        final_ratios = ratioList,
        final_gstar_estimates = GstarList,
        final_gstar_at_dose_grid = GstarAtDoseGridList,
        final_gstar_cis = CIGstarList,
        final_gstar_ratios = ratioGstarList,
        final_tdeot_cis = CITDEOTList,
        final_tdeot_ratios = ratioTDEOTList,
        final_optimal_dose = OptimalDoseList,
        final_optimal_dose_at_dose_grid = OptimalDoseAtDoseGridList,
        fit = fitDLEList,
        fit_eff = fitEffList,
        sigma2_est = sigma2Estimates,
        sigma2_beta_w_est = sigma2betaWEstimates,
        stop_reasons = stopReasons,
        stop_report = stop_report,
        seed = RNGstate
      )

      return(ret)
    } else {
      stopifnot(
        trueNu > 0,
        is.function(trueEff)
      )

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)

      ## get names of arguments (excluding the first one which is the dose)
      trueDLEArgnames <- names(formals(trueDLE))[-1]
      trueEffArgnames <- names(formals(trueEff))[-1]

      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample(x = seq_len(1e5), size = nsim)

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        ## what is now the argument for the truth?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## so this truth DLE function is...
        thisTruthDLE <- function(dose) {
          do.call(
            trueDLE,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments: take only those that
              ## are required by the DLE function
              as.list(thisArgs)[trueDLEArgnames]
            )
          )
        }

        ## and the truth Eff function is:
        thisTruthEff <- function(dose) {
          do.call(
            trueEff,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments: take only those that
              ## are required by the Eff function
              as.list(thisArgs)[trueEffArgnames]
            )
          )
        }

        ## find true sigma2 to generate responses

        trueSigma2 <- 1 / trueNu

        ## start the simulated data with the provided one
        thisData <- object@data

        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisDLEProb <- thisTruthDLE(thisDose)
          thisMeanEff <- thisTruthEff(thisDose)

          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size, dose = thisDose, data = thisData)

          ## simulate DLTs: depends on whether we
          ## separate the first patient or not.
          if (firstSeparate && (thisSize > 1L)) {
            ## dose the first patient
            thisDLTs <- rbinom(
              n = 1L,
              size = 1L,
              prob = thisDLEProb
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = 1L,
                size = 1L,
                prob = thisProb.PL
              )
            }

            thisEff <- rnorm(
              n = 1L,
              mean = thisMeanEff,
              sd = sqrt(trueSigma2)
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisEff.PL <- rnorm(
                n = 1L,
                mean = thisMeanEff.PL,
                sd = sqrt(trueSigma2)
              )
            }

            ## if there is no DLT:
            if (thisDLTs == 0) {
              ## enroll the remaining patients
              thisDLTs <- c(
                thisDLTs,
                rbinom(
                  n = thisSize - 1L,
                  size = 1L,
                  prob = thisDLEProb
                )
              )
              thisEff <- c(
                thisEff,
                rnorm(
                  n = thisSize - 1L,
                  mean = thisMeanEff,
                  sd = sqrt(trueSigma2)
                )
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- c(
                  thisDLTs.PL,
                  rbinom(
                    n = thisSize.PL,
                    size = 1L,
                    prob = thisProb.PL
                  )
                )
                thisEff.PL <- c(
                  thisMeanEff.PL,
                  rnorm(
                    n = thisSize.PL,
                    mean = thisMeanEff.PL,
                    sd = sqrt(trueSigma2)
                  )
                )
              }
            }
          } else {
            ## we can directly dose all patients
            thisDLTs <- rbinom(
              n = thisSize,
              size = 1L,
              prob = thisDLEProb
            )
            thisEff <- rnorm(
              n = thisSize,
              mean = thisMeanEff,
              sd = sqrt(trueSigma2)
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = thisSize.PL,
                size = 1L,
                prob = thisProb.PL
              )
              thisEff.PL <- rnorm(
                n = thisSize.PL,
                mean = thisMeanEff.PL,
                sd = sqrt(trueSigma2)
              )
            }
          }

          ## update the data with this placebo (if any) cohort and then with active dose
          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisData <- update(
              object = thisData,
              x = object@data@doseGrid[1],
              y = thisDLTs.PL,
              w = thisEff.PL,
              check = FALSE
            )

            ## update the data with active dose
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              w = thisEff,
              new_cohort = FALSE
            )
          } else {
            ## update the data with this cohort
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              w = thisEff
            )
          }

          ## Update model estimate in DLE and Eff models
          thisDLEModel <- update(
            object = object@model,
            data = thisData
          )

          thisEffModel <- update(
            object = object@eff_model,
            data = thisData
          )

          thisNu <- thisEffModel@nu

          thisDLEsamples <- mcmc(
            data = thisData,
            model = thisDLEModel,
            options = mcmcOptions
          )

          thisEffsamples <- mcmc(
            data = thisData,
            model = thisEffModel,
            options = mcmcOptions
          )

          thisSigma2 <- if (thisEffModel@use_fixed) {
            1 / thisNu
          } else {
            1 / (as.numeric(thisNu["a"] / thisNu["b"]))
          }

          ## what is the dose limit?
          doselimit <- maxDose(object@increments, data = thisData)

          ## => what is the next best dose?
          next_bd <- nextBest(
            object@nextBest,
            doselimit = doselimit,
            samples = thisDLEsamples,
            model = thisDLEModel,
            data = thisData,
            model_eff = thisEffModel,
            samples_eff = thisEffsamples,
            in_sim = TRUE
          )

          thisDose <- next_bd$next_dose
          thisTDtargetDuringTrial <- next_bd$dose_target_drt
          thisTDtargetDuringTrialAtDoseGrid <- next_bd$next_dose_drt
          thisTDtargetEndOfTrial <- next_bd$dose_target_eot
          thisTDtargetEndOfTrialAtDoseGrid <- next_bd$next_dose_eot
          thisGstar <- next_bd$dose_max_gain
          thisGstarAtDoseGrid <- next_bd$next_dose_max_gain

          Recommend <- min(
            thisTDtargetEndOfTrialAtDoseGrid,
            thisGstarAtDoseGrid
          )

          ## Find the 95 % CI and its ratio (upper to the lower of this 95% CI of each of the estimates)
          thisCITDEOT <- list(
            lower = next_bd$ci_dose_target_eot[1],
            upper = next_bd$ci_dose_target_eot[2]
          )
          thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

          thisCIGstar <- list(
            lower = next_bd$ci_dose_max_gain[1],
            upper = next_bd$ci_dose_max_gain[2]
          )
          thisratioGstar <- next_bd$ci_ratio_dose_max_gain

          ## Find the optimal dose
          OptimalDose <- min(thisGstar, thisTDtargetEndOfTrial)

          if (OptimalDose == thisGstar) {
            thisratio <- thisratioGstar
            thisCI <- thisCIGstar
          } else {
            thisratio <- thisratioTDEOT
            thisCI <- thisCITDEOT
          }

          ## evaluate stopping rules
          stopit <- stopTrial(
            object@stopping,
            dose = thisDose,
            samples = thisDLEsamples,
            model = thisDLEModel,
            data = thisData,
            TDderive = object@nextBest@derive,
            Effmodel = thisEffModel,
            Effsamples = thisEffsamples,
            Gstarderive = object@nextBest@mg_derive
          )
          stopit_results <- h_unpack_stopit(stopit)
        }
        ## get the fit
        thisDLEFit <- fit(
          object = thisDLEsamples,
          model = thisDLEModel,
          data = thisData
        )

        thisEffFit <- fit(
          object = thisEffsamples,
          model = thisEffModel,
          data = thisData
        )

        ## return the results
        thisResult <- list(
          data = thisData,
          dose = thisDose,
          TDtargetDuringTrial = thisTDtargetDuringTrial,
          TDtargetDuringTrialAtDoseGrid = thisTDtargetDuringTrialAtDoseGrid,
          TDtargetEndOfTrial = thisTDtargetEndOfTrial,
          TDtargetEndOfTrialAtDoseGrid = thisTDtargetEndOfTrialAtDoseGrid,
          Gstar = thisGstar,
          GstarAtDoseGrid = thisGstarAtDoseGrid,
          Recommend = Recommend,
          OptimalDose = OptimalDose,
          OptimalDoseAtDoseGrid = Recommend,
          ratio = thisratio,
          CI = thisCI,
          ratioGstar = thisratioGstar,
          CIGstar = thisCIGstar,
          ratioTDEOT = thisratioTDEOT,
          CITDEOT = thisCITDEOT,
          fitDLE = subset(thisDLEFit, select = c(middle, lower, upper)),
          fitEff = subset(thisEffFit, select = c(middle, lower, upper)),
          sigma2est = thisSigma2,
          stop = attr(
            stopit,
            "message"
          ),
          report_results = stopit_results
        )

        return(thisResult)
      }

      resultList <- get_result_list(
        fun = runSim,
        nsim = nsim,
        vars = c(
          "simSeeds",
          "args",
          "nArgs",
          "firstSeparate",
          "trueDLE",
          "trueEff",
          "trueNu",
          "object"
        ),
        parallel = parallel,
        n_cores = nCores
      )

      ## put everything in the Simulations format:

      ## setup the list for the simulated data objects
      dataList <- lapply(resultList, "[[", "data")

      ## the vector of the final dose recommendations
      recommendedDoses <- as.numeric(sapply(resultList, "[[", "Recommend"))

      ## set up list for the final TD during Trial Estimate
      TDtargetDuringTrialList <- as.numeric(sapply(
        resultList,
        "[[",
        "TDtargetDuringTrial"
      ))

      ## set up list for the final TD End of Trial Estimate
      TDtargetEndOfTrialList <- as.numeric(sapply(
        resultList,
        "[[",
        "TDtargetEndOfTrial"
      ))

      ## set up list for the final TD during Trial estimate at dose Grid
      TDtargetDuringTrialDoseGridList <- as.numeric(sapply(
        resultList,
        "[[",
        "TDtargetDuringTrialAtDoseGrid"
      ))

      ## set up list for the final TD End Of Trial estimate at dose Grid
      TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(
        resultList,
        "[[",
        "TDtargetEndOfTrialAtDoseGrid"
      ))

      ## set up list for the final Gstar estimates
      GstarList <- as.numeric(sapply(resultList, "[[", "Gstar"))

      ## set up list for the final Gstar estimates at dose grid
      GstarAtDoseGridList <- as.numeric(sapply(
        resultList,
        "[[",
        "GstarAtDoseGrid"
      ))

      ## set up list for final optimal dose estimates
      OptimalDoseList <- as.numeric(sapply(resultList, "[[", "OptimalDose"))

      ## set up list for final optimal dose estimates at dose Grid
      OptimalDoseAtDoseGridList <- as.numeric(sapply(
        resultList,
        "[[",
        "Recommend"
      ))

      ## Set up the list for the final 95% CI obtained
      CIList <- lapply(resultList, "[[", "CI")

      ## Set up the list for the final ratios obtained
      ratioList <- as.numeric(sapply(resultList, "[[", "ratio"))

      ## Set up the list for the final 95% CI of the TDtarget End Of Trial obtained
      CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

      ## Set up the list for the final ratios of the TDtarget End Of Trial obtained
      ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

      ## Set up the list for the final 95% CI of the Gstar obtained
      CIGstarList <- lapply(resultList, "[[", "CIGstar")

      ## Set up the list for the final ratios of the Gstar obtained
      ratioGstarList <- as.numeric(sapply(resultList, "[[", "ratioGstar"))

      ## set up the list for the final fits for both DLE and efficacy
      fitDLEList <- lapply(resultList, "[[", "fitDLE")
      fitEffList <- lapply(resultList, "[[", "fitEff")
      ## the vector of the sigma2
      sigma2Estimates <- as.numeric(sapply(resultList, "[[", "sigma2est"))

      ## the reasons for stopping
      stopReasons <- lapply(resultList, "[[", "stop")

      # individual stopping rule results as matrix, labels as column names
      stop_results <- lapply(resultList, "[[", "report_results")
      stop_report <- as.matrix(do.call(rbind, stop_results))

      ## return the results in the Simulations class object
      ret <- PseudoDualSimulations(
        data = dataList,
        doses = recommendedDoses,
        final_td_target_during_trial_estimates = TDtargetDuringTrialList,
        final_td_target_end_of_trial_estimates = TDtargetEndOfTrialList,
        final_td_target_during_trial_at_dose_grid = TDtargetDuringTrialDoseGridList,
        final_td_target_end_of_trial_at_dose_grid = TDtargetEndOfTrialDoseGridList,
        final_cis = CIList,
        final_ratios = ratioList,
        final_gstar_estimates = GstarList,
        final_gstar_at_dose_grid = GstarAtDoseGridList,
        final_gstar_cis = CIGstarList,
        final_gstar_ratios = ratioGstarList,
        final_tdeot_cis = CITDEOTList,
        final_tdeot_ratios = ratioTDEOTList,
        final_optimal_dose = OptimalDoseList,
        final_optimal_dose_at_dose_grid = OptimalDoseAtDoseGridList,
        fit = fitDLEList,
        fit_eff = fitEffList,
        sigma2_est = sigma2Estimates,
        stop_reasons = stopReasons,
        stop_report = stop_report,
        seed = RNGstate
      )
      return(ret)
    }
  }
)

## --------------------------------------------------------------------------

##' Simulate outcomes from a time-to-DLT augmented CRM design (`DADesign`)
##'
##' @param object the \code{\linkS4class{DADesign}} object we want to simulate
##'   data from
##' @param nsim the number of simulations (default: 1)
##' @param seed see \code{\link{set_seed}}
##' @param truthTox a function which takes as input a dose (vector) and returns the
##'   true probability (vector) for toxicity and the time DLT occurs. Additional
##'   arguments can be supplied in \code{args}.
##' @param truthSurv a CDF which takes as input a time (vector) and returns
##'   the true cumulative probability (vector) that the DLT would occur conditioning on the patient
##'   has DLTs.
##' @param trueTmax (`number` or `NULL`)\cr the true maximum time at which DLTs can occur. Note that this must be larger thank `Tmax` from the `object`'s base data, which is the length of the DLT window, i.e. until which time DLTs are officially declared as such and used in the trial.
##' @param args data frame with arguments for the \code{truth} function. The
##'   column names correspond to the argument names, the rows to the values of the
##'   arguments. The rows are appropriately recycled in the \code{nsim}
##'   simulations. In order to produce outcomes from the posterior predictive
##'   distribution, e.g, pass an \code{object} that contains the data observed so
##'   far, \code{truth} contains the \code{prob} function from the model in
##'   \code{object}, and \code{args} contains posterior samples from the model.
##' @param firstSeparate enroll the first patient separately from the rest of
##'   the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##'   in this patient.
##' @param deescalate deescalation when a DLT occurs in cohorts with lower dose
##'   level.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##'   giving the MCMC options for each evaluation in the trial. By default,
##'   the standard options are used.
##' @param DA document or rename this parameter to make it more meaningful
##' @param parallel should the simulation runs be parallelized across the
##'   clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine (maximum 5)
##' @param \dots not used
##' @param derive a named list of functions which derives statistics, based on the
##' vector of posterior MTD samples. Each list element must therefore accept
##' one and only one argument, which is a numeric vector, and return a number.
##'
##' @return an object of class \code{\linkS4class{Simulations}}
##'
##' @example examples/design-method-simulate-DADesign.R
##' @export
##' @keywords methods
setMethod(
  "simulate",
  signature = signature(
    object = "DADesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  def = function(
    object,
    nsim = 1L,
    seed = NULL,
    truthTox,
    truthSurv,
    trueTmax = NULL,
    args = NULL,
    firstSeparate = FALSE,
    deescalate = TRUE,
    mcmcOptions = McmcOptions(),
    DA = TRUE,
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5),
    derive = list(),
    ...
  ) {
    ## checks and extracts
    assert_function(truthTox)
    assert_function(truthSurv)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    args <- as.data.frame(args)
    nArgs <- max(nrow(args), 1L)

    ## seed handling
    RNGstate <- set_seed(seed)

    ## from this,
    ## generate the individual seeds for the simulation runs
    simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

    ## Define functions which are useful in DLT Surv generation
    inverse <- function(f, lower = -100, upper = 100) {
      function(y) {
        uniroot((function(x) f(x) - y), lower = lower, upper = upper)[1]$root
      }
    }

    ## The DLT window length
    thisData <- object@data
    Tmax <- thisData@Tmax

    if (is.null(trueTmax)) {
      trueTmax <- Tmax
    } else if (trueTmax < Tmax) {
      warning("trueTmax < Tmax! trueTmax is set to Tmax")
      trueTmax <- Tmax
    }

    ## Calculate the inverse function of Surv to DLT CDF
    itruthSurv <- inverse(truthSurv, 0, trueTmax)

    ## generate random variable of Surv to DLT data; return Tmax when no
    ## DLT
    rtruthSurv <- function(DLT, Tmax_, itruthSurv = itruthSurv) {
      u_i <- rep(-100, length(DLT)) # remember to check this

      if (sum(DLT == 0) > 0) {
        u_i[DLT == 0] <- Tmax_
      }

      if (sum(DLT == 1) > 0) {
        u_i[DLT == 1] <- unlist(lapply(runif(sum(DLT == 1), 0, 1), itruthSurv))
      }

      # make sure that results are always positive, otherwise we get
      # problems below.
      u_i[u_i == 0] <- 0.5
      return(u_i)
    }

    # A function to return follow up fulfull yes (TRUE) vs no (FALSE);
    ready_to_open <- function(day, window, thisSurv) {
      size <- length(thisSurv)
      # the date the patient starts;
      start_time <- apply(rbind(thisSurv[-size], window$patientGap[-1]), 2, min)
      # the relative time for each patient on the specified "date";
      individule_check <- day - cumsum(c(0, start_time))
      # the minial number should be 0;
      individule_check[individule_check < 0] <- 0
      follow_up <- apply(rbind(thisSurv, individule_check), 2, min)
      return(
        all(
          (follow_up - apply(rbind(window$patientFollow, thisSurv), 2, min)) >=
            0
        ) &
          (max(follow_up) >= min(window$patientFollowMin, max(thisSurv)))
      )
    }

    ## assume we have surfficient patients, i.e. patient can be immediately enrolled
    ## once the trial accumulation is open. This function will tell you when to open
    ## the next cohort;
    # this function applys to all trials;
    nextOpen <- function(window, thisSurv) {
      size <- length(thisSurv)

      window$patientGap <- window$patientGap[1:size] ## if length(window$pt)>length(thisSurv), assume the first length(thisSurv) patients were enrolled;
      ## if the DLT happens before the end of DLT window, then the next
      ## cohort/enrollment of the next patient would happened earlier;
      start_time <- apply(rbind(thisSurv[-size], window$patientGap[-1]), 2, min)
      # duration of the cohort (all DLT windows finished);
      maxT <- max(thisSurv + cumsum(c(0, start_time)))

      meetrequire <- sapply(1:maxT, function(i) {
        ready_to_open(i, window, thisSurv)
      })
      if (sum(meetrequire) > 0) {
        # the earliest time that the require is met;
        time <- min(c(1:maxT)[meetrequire])
      } else {
        time <- maxT
      }

      return(time)
    }

    ## the function to produce the run a single simulation
    ## with index "iterSim"
    runSim <- function(iterSim) {
      ## set the seed for this run
      set.seed(simSeeds[iterSim])

      # check<<-simSeeds[iterSim]
      ## what is now the argument for the truth?
      ## (appropriately recycled)
      thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

      ## so this truth is...
      thisTruth <- function(dose) {
        do.call(
          truthTox,
          ## First argument: the dose
          c(
            dose,
            ## Following arguments
            thisArgs
          )
        )
      }

      ## start the simulated data with the provided one
      thisData <- object@data

      # In case there are placebo
      if (thisData@placebo) {
        ## what is the probability for tox. at placebo?
        thisProb.PL <- thisTruth(object@data@doseGrid[1])
      }

      ## shall we stop the trial?
      ## First, we want to continue with the starting dose.
      ## This variable is updated after each cohort in the loop.
      stopit <- FALSE

      ## the time clock for the study, set to 0 when the first simulated
      ## patient initially dosed;
      trialtime <- 0

      # initiate the true DLT, true DLT Surv and the C1/D1 for each patients
      factDLTs <- thisData@y
      factSurv <- thisData@u
      factT0 <- thisData@t0

      ## what is the next dose to be used?
      ## initialize with starting dose
      thisDose <- object@startingDose

      ## inside this loop we simulate the whole trial, until stopping
      while (!stopit) {
        ## what is the probability for tox. at this dose?
        thisProb <- thisTruth(thisDose)

        ## what is the cohort size at this dose?
        thisSize <- size(object@cohort_size, dose = thisDose, data = thisData)

        thisSafetywindow <- windowLength(object@safetyWindow, thisSize)
        # better: add a checkpoint in safetywindow--dim(safetywindow$pt)==thisSize;

        ## In case there are placebo
        if (thisData@placebo) {
          thisSize.PL <- size(
            object@pl_cohort_size,
            dose = thisDose,
            data = thisData
          )
        }

        ## simulate DLTs: depends on whether we
        ## separate the first patient or not.
        ## amended on May 24: if any patient had DLT before the
        ## first patient finished a staggered window
        ## further enrollment will be stopped;

        if (firstSeparate && (thisSize > 1L)) {
          ## dose the first patient
          thisDLTs <- rbinom(
            n = 1L,
            size = 1L,
            prob = thisProb
          )

          if (thisData@placebo) {
            thisDLTs.PL <- rbinom(
              n = 1L,
              size = 1L,
              prob = thisProb.PL
            )
          }

          thisSurv <- ceiling(rtruthSurv(
            DLT = thisDLTs,
            Tmax_ = trueTmax,
            itruthSurv = itruthSurv
          ))

          if (Tmax < trueTmax) {
            thisDLTs[thisDLTs == 1 & thisSurv > Tmax] <- 0

            thisSurv <- apply(
              rbind(thisSurv, rep(Tmax, length(thisSurv))),
              2,
              min
            )
          }

          thisT0 <- trialtime

          ## if there is no DLT during Safety window:
          ## and no DLTs of previous patients-->

          # need to update the DataDA object
          tempData <- update(
            object = thisData,
            y = c(factDLTs, thisDLTs), #### the y will be updated according to u
            u = c(factSurv, thisSurv),
            t0 = c(factT0, thisT0),
            x = thisDose,
            trialtime = trialtime + thisSafetywindow$patientGap[2]
          ) #### the u will be updated over time

          temptime <- (tempData@u + tempData@t0)[
            tempData@y == 1 & tempData@x <= thisDose
          ]

          # identify number of DLTs occurs during the thisSafetywindow$pt[2]
          # if(thisSurv>thisSafetywindow$pt[2])
          if (sum(temptime > trialtime) == 0) {
            ## enroll the remaining patients
            thisDLTs <- c(
              thisDLTs,
              rbinom(
                n = thisSize - 1L,
                size = 1L,
                prob = thisProb
              )
            )

            thisSurv <- c(
              thisSurv,
              ceiling(rtruthSurv(
                thisDLTs[-1],
                trueTmax,
                itruthSurv = itruthSurv
              ))
            )

            if (Tmax < trueTmax) {
              thisDLTs[thisDLTs == 1 & thisSurv > Tmax] <- 0

              thisSurv <- apply(
                rbind(thisSurv, rep(Tmax, length(thisSurv))),
                2,
                min
              )
            }

            # in case any DLT happens before the end of the safety window;
            real_window <- apply(
              rbind(thisSurv[-thisSize], thisSafetywindow$patientGap[-1]),
              2,
              min
            )

            thisT0 <- trialtime + c(0, cumsum(real_window))

            if (thisData@placebo && (thisSize.PL > 1L)) {
              thisDLTs.PL <- c(
                thisDLTs.PL,
                rbinom(
                  n = thisSize.PL - 1L,
                  size = 1L,
                  prob = thisProb.PL
                )
              )
            }
          }

          rm(tempData)
          rm(temptime)
        } else {
          ## we can directly dose all patients
          thisDLTs <- rbinom(
            n = thisSize,
            size = 1L,
            prob = thisProb
          )

          thisSurv <- ceiling(rtruthSurv(
            thisDLTs,
            trueTmax,
            itruthSurv = itruthSurv
          ))
          ## should return a vector with a same dimention as thisDLTs
          if (Tmax < trueTmax) {
            thisDLTs[thisDLTs == 1 & thisSurv > Tmax] <- 0

            thisSurv <- apply(
              rbind(thisSurv, rep(Tmax, length(thisSurv))),
              2,
              min
            )
          }
          # in case any DLT happens before the end of the safety window;
          real_window <- apply(
            rbind(thisSurv[-thisSize], thisSafetywindow$patientGap[-1]),
            2,
            min
          )

          thisT0 <- trialtime + c(0, cumsum(real_window))
          ## should return a vector with a same dimention as thisDLTs

          if (thisData@placebo) {
            thisDLTs.PL <- rbinom(
              n = thisSize.PL,
              size = 1L,
              prob = thisProb.PL
            )
          }
        }

        ## update the data with this placebo (if any)
        ## cohort and then with active dose
        if (thisData@placebo) {
          thisData <- update(
            object = thisData,
            x = object@data@doseGrid[1],
            y = thisDLTs.PL
          )

          ## update the data with active dose
          thisData <- update(
            object = thisData,
            x = thisDose,
            y = thisDLTs,
            new_cohort = FALSE
          )

          ## JZ: additional part for DADesign--when to start the next cohort
          trialtime <- trialtime +
            nextOpen(
              window = thisSafetywindow,
              thisSurv = thisSurv
            )
        } else {
          ## JZ: since the whole y and u column need update.
          ## factDLTs and factSuev get update and then calculate the y and u value in
          ## thisData object
          #
          #                                                   ## update the data with this cohort
          #                                                   thisData <- update(object=thisData,
          #                                                                      x=thisDose,  ####the x will be constantly updated according to u
          #                                                                      y=thisDLTs,
          #                                                                      u=thisSurv)  ####the u will be constantly updated

          factDLTs <- c(factDLTs, thisDLTs)

          factSurv <- c(factSurv, thisSurv) # better: check the data type of factSurv and thisSurv;

          factT0 <- c(factT0, thisT0)

          tempnext <- nextOpen(
            window = thisSafetywindow,
            thisSurv = thisSurv
          )

          ##### if there are DLTs, patients in the higher cohorts will be dosed a lower dose or discontinue.
          if (deescalate == TRUE) {
            newDLTid <- ((factSurv + factT0) > trialtime &
              (factSurv + factT0 - trialtime) <= tempnext &
              factDLTs == 1)

            newDLTnum <- c(1:length(factDLTs))[newDLTid]

            newDLTnum <- newDLTnum[
              newDLTnum <= (length(factDLTs) - length(thisDLTs))
            ]

            # if(ifelse(sum(newDLTnum)==0,Inf,min(newDLTnum))<=(length(factDLTs)-length(thisDLTs))){
            if (length(newDLTnum) > 0) {
              for (DLT_loop in newDLTnum) {
                newDLTtime <- (factSurv + factT0)[DLT_loop]

                # identify higher dose--impacted patients:
                deescalateID <- c(DLT_loop:length(factDLTs))[
                  c(thisData@x, rep(thisDose, length(thisDLTs)))[
                    DLT_loop:length(factDLTs)
                  ] >
                    thisData@x[DLT_loop]
                ]

                ## DLT will be observed once the followup time >= the time to DLT
                factDLTs[deescalateID] <- as.integer(
                  factDLTs * (newDLTtime >= factT0 + factSurv)
                )[deescalateID]

                ## update DLT free survival time
                factSurv[deescalateID] <- apply(
                  rbind(factSurv, newDLTtime - factT0),
                  2,
                  min
                )[deescalateID]
              }

              tempnext <- min(
                tempnext,
                max((factSurv + factT0)[
                  (length(factDLTs) - length(thisDLTs) + 1):length(factDLTs)
                ]) -
                  trialtime
              )
            }
          }

          ## JZ: future work: additional part for DADesign--when to start the next cohort
          ## nextOpen can be modified to incorporate different patient enrollment rate;
          ## currently assume we have sufficient patients;
          ## If there is a gap between cohorts for cohort manager meeting, it can be
          ## added to here;

          trialtime <- trialtime + tempnext

          ## Update thisData
          ## according to what can be observed by the time when the next cohort open;

          thisData <- update(
            object = thisData,
            y = factDLTs, #### the y will be updated according to u
            u = factSurv,
            t0 = factT0,
            x = thisDose,
            trialtime = trialtime
          ) #### the u will be updated over time

          try(
            if (
              length(thisData@x) != length(thisData@u) ||
                length(thisData@u) != length(thisData@y)
            ) {
              stop("x,y,u dimention error")
            }
          )
        }

        # testthisdata<<-thisData

        ## what is the dose limit? #JZ should
        ## still work for the DataDA object
        doselimit <- maxDose(object@increments, data = thisData)

        ## generate samples from the model
        if (DA == TRUE) {
          thisSamples <- mcmc(
            data = thisData,
            model = object@model,
            options = mcmcOptions
          )
        } else if (DA == FALSE) {
          temp_model <- LogisticLogNormal(
            mean = object@model@params@mean,
            cov = object@model@params@cov,
            ref_dose = object@model@refDose
          )

          trunk_Data <- Data(
            x = thisData@x,
            y = thisData@y,
            doseGrid = thisData@doseGrid,
            cohort = thisData@cohort,
            ID = thisData@ID
          )

          thisSamples <- mcmc(
            data = trunk_Data,
            model = temp_model,
            options = mcmcOptions
          )
        }

        ## => what is the next best dose?
        thisDose <- nextBest(
          object@nextBest,
          doselimit = doselimit,
          samples = thisSamples,
          model = object@model,
          data = thisData
        )$value

        ## evaluate stopping rules
        stopit <- stopTrial(
          object@stopping,
          dose = thisDose,
          samples = thisSamples,
          model = object@model,
          data = thisData
        )
        stopit_results <- h_unpack_stopit(stopit)
      }

      ## get the fit
      thisFit <- fit(
        object = thisSamples,
        model = object@model,
        data = thisData
      )

      # Get the MTD estimate from the samples.

      target_dose_samples <- dose(
        mean(object@nextBest@target),
        model = object@model,
        samples = thisSamples
      )

      # Create a function for additional statistical summary.
      additional_stats <- lapply(derive, function(f) f(target_dose_samples))

      ## return the results
      thisResult <-
        list(
          data = thisData,
          dose = thisDose,
          duration = trialtime,
          fit = subset(thisFit, select = c(middle, lower, upper)),
          stop = attr(
            stopit,
            "message"
          ),
          report_results = stopit_results,
          additional_stats = additional_stats
        )
      return(thisResult)
    }

    resultList <- get_result_list(
      fun = runSim, ## remove
      nsim = nsim,
      vars = c(
        "simSeeds",
        "args",
        "nArgs",
        "firstSeparate",
        "truthTox",
        "truthSurv",
        "object",
        "mcmcOptions",
        "nextOpen",
        "ready_to_open"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    ## put everything in the Simulations format:

    ## setup the list for the simulated data objects
    dataList <- lapply(resultList, "[[", "data")

    ## the vector of the final dose recommendations
    recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))

    ## the vector of the final trial duration;
    trialduration <- as.numeric(sapply(resultList, "[[", "duration"))

    ## setup the list for the final fits
    fitList <- lapply(resultList, "[[", "fit")

    ## the reasons for stopping
    stopReasons <- lapply(resultList, "[[", "stop")

    # individual stopping rule results as matrix, labels as column names
    stop_results <- lapply(resultList, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))

    additional_stats <- lapply(resultList, "[[", "additional_stats")

    ## return the results in the Simulations class object
    ret <- DASimulations(
      data = dataList,
      doses = recommendedDoses,
      fit = fitList,
      trialduration = trialduration,
      stop_report = stop_report,
      stop_reasons = stopReasons,
      additional_stats = additional_stats,
      seed = RNGstate
    )

    return(ret)
  }
)

## --------------------------------------------------------------------------
# nolint end

# simulate ----

## DesignGrouped ----

#' Simulate Method for the [`DesignGrouped`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simulate method for [`DesignGrouped`] designs.
#'
#' @param object (`DesignGrouped`)\cr the design we want to simulate trials from.
#' @param nsim (`number`)\cr how many trials should be simulated.
#' @param seed (`RNGstate`)\cr generated with [set_seed()].
#' @param truth (`function`)\cr a function which takes as input a dose (vector) and
#'   returns the true probability (vector) for toxicity for the mono arm.
#'   Additional arguments can be supplied in `args`.
#' @param combo_truth (`function`)\cr same as `truth` but for the combo arm.
#' @param args (`data.frame`)\cr optional `data.frame` with arguments that work
#'   for both the `truth` and `combo_truth` functions. The column names correspond to
#'   the argument names, the rows to the values of the arguments. The rows are
#'   appropriately recycled in the `nsim` simulations.
#' @param firstSeparate (`flag`)\cr whether to enroll the first patient separately
#'   from the rest of the cohort and close the cohort in case a DLT occurs in this
#'   first patient.
#' @param mcmcOptions (`McmcOptions`)\cr MCMC options for each evaluation in the trial.
#' @param parallel (`flag`)\cr whether the simulation runs are parallelized across the
#'   cores of the computer.
#' @param nCores (`number`)\cr how many cores should be used for parallel computing.
#' @param ... not used.
#'
#' @return A list of `mono` and `combo` simulation results as [`Simulations`] objects.
#'
#' @aliases simulate-DesignGrouped
#' @export
#' @example examples/Design-method-simulate-DesignGrouped.R
#'
setMethod(
  "simulate",
  signature = signature(
    object = "DesignGrouped",
    nsim = "ANY",
    seed = "ANY"
  ),
  def = function(
    object,
    nsim = 1L,
    seed = NULL,
    truth,
    combo_truth,
    args = data.frame(),
    firstSeparate = FALSE,
    mcmcOptions = McmcOptions(),
    parallel = FALSE,
    nCores = min(parallelly::availableCores(), 5),
    ...
  ) {
    nsim <- as.integer(nsim)
    assert_function(truth)
    assert_function(combo_truth)
    assert_data_frame(args)
    assert_count(nsim, positive = TRUE)
    assert_flag(firstSeparate)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    n_args <- max(nrow(args), 1L)
    rng_state <- set_seed(seed)
    sim_seeds <- sample.int(n = 2147483647, size = nsim)

    run_sim <- function(iter_sim) {
      set.seed(sim_seeds[iter_sim])
      current <- list(mono = list(), combo = list())
      # Define true toxicity functions.
      current$args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]
      current$mono$truth <- function(dose) do.call(truth, c(dose, current$args))
      current$combo$truth <- function(dose) {
        do.call(combo_truth, c(dose, current$args))
      }
      # Start the simulated data with the provided one.
      current$mono$data <- object@mono@data
      current$combo$data <- object@combo@data
      # We are in the first cohort and continue for mono and combo.
      current$first <- TRUE
      current$mono$stop <- current$combo$stop <- FALSE

      # What are the next doses to be used? Initialize with starting doses.
      if (
        object@same_dose_for_all ||
          (!object@first_cohort_mono_only && object@same_dose_for_start)
      ) {
        current$mono$dose <- current$combo$dose <- min(
          object@mono@startingDose,
          object@combo@startingDose
        )
      } else {
        current$mono$dose <- object@mono@startingDose
        current$combo$dose <- object@combo@startingDose
      }

      # Inside this loop we simulate the whole trial, until stopping.
      while (!(current$mono$stop && current$combo$stop)) {
        if (!current$mono$stop) {
          cohort_size_mono <- size(
            object@mono@cohort_size,
            dose = current$mono$dose,
            data = current$mono$data
          )
          this_prob_mono <- current$mono$truth(current$mono$dose)
          current$mono$data <- current$mono$data %>%
            h_determine_dlts(
              dose = current$mono$dose,
              prob = this_prob_mono,
              cohort_size = cohort_size_mono,
              first_separate = firstSeparate
            )
        }
        if (
          !current$combo$stop &&
            (!current$first || !object@first_cohort_mono_only)
        ) {
          cohort_size_combo <- size(
            object@combo@cohort_size,
            dose = current$combo$dose,
            data = current$combo$data
          )
          this_prob_combo <- current$combo$truth(current$combo$dose)
          current$combo$data <- current$combo$data %>%
            h_determine_dlts(
              dose = current$combo$dose,
              prob = this_prob_combo,
              cohort_size = cohort_size_combo,
              first_separate = firstSeparate
            )
        }

        current$grouped <- h_group_data(current$mono$data, current$combo$data)
        current$samples <- mcmc(current$grouped, object@model, mcmcOptions)
        if (!current$mono$stop) {
          current$mono$limit <- maxDose(
            object@mono@increments,
            data = current$mono$data
          )
          current$mono$dose <- object@mono@nextBest %>%
            nextBest(
              current$mono$limit,
              current$samples,
              object@model,
              current$grouped,
              group = "mono"
            )
          current$mono$dose <- current$mono$dose$value
        }
        if (
          !current$combo$stop &&
            (!current$first || !object@first_cohort_mono_only)
        ) {
          current$combo$limit <- if (is.na(current$mono$dose)) {
            0
          } else {
            maxDose(object@combo@increments, current$combo$data) %>%
              min(current$mono$dose, na.rm = TRUE)
          }
          current$combo$dose <- object@combo@nextBest %>%
            nextBest(
              current$combo$limit,
              current$samples,
              object@model,
              current$grouped,
              group = "combo"
            )
          current$combo$dose <- current$combo$dose$value
          current$combo$stop <- object@combo@stopping %>%
            stopTrial(
              current$combo$dose,
              current$samples,
              object@model,
              current$combo$data,
              group = "combo"
            )
          current$combo$results <- h_unpack_stopit(current$combo$stop)
        }
        if (!current$mono$stop) {
          current$mono$stop <- object@mono@stopping %>%
            stopTrial(
              current$mono$dose,
              current$samples,
              object@model,
              current$mono$data,
              group = "mono",
              external = current$combo$stop
            )
          current$mono$results <- h_unpack_stopit(current$mono$stop)
        }
        if (
          object@same_dose_for_all && !current$mono$stop && !current$combo$stop
        ) {
          current$mono$dose <- current$combo$dose <- min(
            current$mono$dose,
            current$combo$dose
          )
        }
        if (current$first) {
          current$first <- FALSE
          if (object@first_cohort_mono_only && object@same_dose_for_start) {
            current$mono$dose <- current$combo$dose <- min(
              current$mono$dose,
              current$combo$dose
            )
          }
        }
      }
      current$mono$fit <- fit(
        current$samples,
        object@model,
        current$grouped,
        group = "mono"
      )
      current$combo$fit <- fit(
        current$samples,
        object@model,
        current$grouped,
        group = "combo"
      )
      lapply(
        X = current[c("mono", "combo")],
        FUN = with,
        list(
          data = data,
          dose = dose,
          fit = subset(fit, select = -dose),
          stop = attr(stop, "message"),
          results = results
        )
      )
    }
    vars_needed <- c(
      "simSeeds",
      "args",
      "nArgs",
      "truth",
      "combo_truth",
      "firstSeparate",
      "object",
      "mcmcOptions"
    )

    result_list <- get_result_list(run_sim, nsim, vars_needed, parallel, nCores)
    # Now we have a list with each element containing mono and combo. Reorder this a bit:
    result_list <- list(
      mono = lapply(result_list, "[[", "mono"),
      combo = lapply(result_list, "[[", "combo")
    )
    # Put everything in a list with both mono and combo Simulations:
    lapply(result_list, function(this_list) {
      data_list <- lapply(this_list, "[[", "data")
      recommended_doses <- as.numeric(sapply(this_list, "[[", "dose"))
      fit_list <- lapply(this_list, "[[", "fit")
      stop_reasons <- lapply(this_list, "[[", "stop")
      report_results <- lapply(this_list, "[[", "results")
      stop_report <- as.matrix(do.call(rbind, report_results))
      additional_stats <- lapply(this_list, "[[", "additional_stats")

      Simulations(
        data = data_list,
        doses = recommended_doses,
        fit = fit_list,
        stop_reasons = stop_reasons,
        stop_report = stop_report,
        additional_stats = additional_stats,
        seed = rng_state
      )
    })
  }
)

# tidy ----

## tidy-DualDesign ----

#' @rdname tidy
#' @aliases tidy-DualDesign
#' @example examples/Design-method-tidyDualDesign.R
#'
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "DualDesign"),
  definition = function(x, ...) {
    # Some Design objects have complex attributes whose structure is not supported.
    rv <- h_tidy_all_slots(x, attributes = FALSE) %>% h_tidy_class(x)
    if (length(rv) == 1) {
      rv[[names(rv)[1]]] %>% h_tidy_class(x)
    } else {
      rv
    }
  }
)

# Validate-class ----

#' `Validate`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The [`Validate`] class is a Reference Class
#' to help programming validation for new S4 classes.
#'
#' @details Starting from an empty `msg` vector, with each check
#'   that is returning `FALSE` the vector gets a new element - the string
#'   explaining the failure of the validation.
#'
#' @name Validate
#' @field msg (`character`)\cr the cumulative messages.
#'
Validate <- setRefClass(
  Class = "Validate",
  fields = list(msg = "character"),
  methods = list(
    check = function(test, string = "") {
      "Check whether the \\code{test} is \\code{TRUE}; if so, return \\code{NULL}.
      Otherwise, add the \\code{string} message into the cumulative messages vector \\code{msg}."
      assert_flag(test)
      assert_string(string)
      if (test) {
        NULL
      } else {
        msg <<- c(msg, string)
      }
    },
    result = function() {
      "Return either cumulative messages vector \\code{msg}
      (which contains the error messages from all the checks),
      or \\code{NULL}, if \\code{msg} is empty (i.e. all the checks were successful)."
      if (length(msg) > 0) {
        msg
      } else {
        TRUE
      }
    }
  )
)

# positive_number-class ----

#' `positive_number`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' The [`positive_number`] class is a class to store not `NULL`, non `NA`,
#' finite and strictly positive numerical value. It is mainly used to store
#' reference dose value in model classes.
#'
#' @name positive_number
#'
positive_number <- setClass(
  Class = "positive_number",
  contains = "numeric",
  validity = function(object) {
    v <- Validate()
    v$check(
      test_number(object, finite = TRUE) && object > 0,
      "Object's value must be strictly positive"
    )
    v$result()
  }
)

# nolint start

##' Helper function for value matching with tolerance
##'
##' This is a modified version of \code{match} that supports tolerance.
##'
##' @param x the values to be matched
##' @param table the values to be matched against
##' @return A vector of the same length as \code{x} or
##'  empty vector if \code{table} is empty.
##'
##' @export
##' @keywords programming
match_within_tolerance <- function(x, table) {
  if (length(table) == 0) {
    return(integer())
  }

  as.integer(sapply(x, function(.x) {
    which(sapply(table, function(.table) {
      isTRUE(all.equal(
        .x,
        .table,
        tolerance = 1e-10,
        check.names = FALSE,
        check.attributes = FALSE
      ))
    }))[1]
  }))
}

##' checks for whole numbers (integers)
##'
##' @param x the numeric vector
##' @param tol the tolerance
##' @return TRUE or FALSE for each element of x
##'
##' @keywords internal
is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) {
  abs(x - round(x)) < tol
}


##' Safe conversion to integer vector
##'
##' @param x the numeric vector
##' @return the integer vector
##'
##' @keywords internal
safeInteger <- function(x) {
  testres <- is.wholenumber(x)
  if (!all(testres)) {
    notInt <- which(!testres)
    stop(paste(
      "elements",
      paste(notInt, sep = ", "),
      "of vector are not integers!"
    ))
  }
  as.integer(x)
}

##' Shorthand for logit function
##'
##' @param x the function argument
##' @return the logit(x)
##'
##' @export
##' @keywords programming
logit <- function(x) {
  qlogis(x)
}

##' Shorthand for probit function
##'
##' @param x the function argument
##' @return the probit(x)
##'
##' @export
##' @keywords programming
probit <- function(x) {
  qnorm(x)
}

##' Open the example pdf for crmPack
##'
##' Calling this helper function should open the example.pdf document,
##' residing in the doc subfolder of the package installation directory.
##'
##' @return nothing
##' @export
##' @keywords documentation
##' @author Daniel Sabanes Bove \email{sabanesd@@rconis.com}
crmPackExample <- function() {
  crmPath <- system.file(package = "crmPack")
  printVignette(list(PDF = "example.pdf", Dir = crmPath))
  ## instead of utils:::print.vignette
}

##' Open the browser with help pages for crmPack
##'
##' This convenience function opens your browser with the help pages for
##' crmPack.
##'
##' @return nothing
##' @export
##' @importFrom utils help
##' @keywords documentation
##' @author Daniel Sabanes Bove \email{sabanesd@@rconis.com}
crmPackHelp <- function() {
  utils::help(package = "crmPack", help_type = "html")
}

#' Plot `gtable` Objects
#'
#' This is needed because `crmPack` uses [gridExtra::arrangeGrob()] to combine
#' `ggplot2` plots, and the resulting `gtable` object is not plotted otherwise
#' when implicitly printing it in the console, e.g.
#'
#' @method plot gtable
#' @param x (`gtable`)\cr object to plot.
#' @param ... additional parameters for [grid::grid.draw()].
#'
#' @export
plot.gtable <- function(x, ...) {
  grid::grid.draw(x, ...)
}

#' @method print gtable
#' @rdname plot.gtable
#' @export
print.gtable <- function(x, ...) {
  plot(x, ...)
}

##' Taken from utils package (print.vignette)
##'
##' @importFrom tools file_ext
##' @importFrom utils browseURL
##' @keywords internal
printVignette <- function(x, ...) {
  if (nzchar(out <- x$PDF)) {
    ext <- tools::file_ext(out)
    out <- file.path(x$Dir, "doc", out)
    if (tolower(ext) == "pdf") {
      pdfviewer <- getOption("pdfviewer")
      if (identical(pdfviewer, "false")) {} else if (
        .Platform$OS.type == "windows" &&
          identical(
            pdfviewer,
            file.path(R.home("bin"), "open.exe")
          )
      ) {
        shell.exec(out)
      } else {
        system2(pdfviewer, shQuote(out), wait = FALSE)
      }
    } else {
      browseURL(out)
    }
  } else {
    warning(
      gettextf("vignette %s has no PDF/HTML", sQuote(x$Topic)),
      call. = FALSE,
      domain = NA
    )
  }
  invisible(x)
}

##' Compute the density of Inverse gamma distribution
##' @param x vector of quantiles
##' @param a the shape parameter of the inverse gamma distribution
##' @param b the scale parameter of the inverse gamma distribution
##' @param log logical; if TRUE, probabilities p are given as log(p)
##' @param normalize logical; if TRUE, the output will be normalized
##'
##' @keywords internal
dinvGamma <- function(x, a, b, log = FALSE, normalize = TRUE) {
  ret <- -(a + 1) * log(x) - b / x
  if (normalize) {
    ret <- ret + a * log(b) - lgamma(a)
  }
  if (log) {
    return(ret)
  } else {
    return(exp(ret))
  }
}

##' Compute the distribution function of Inverse gamma distribution
##'
##' @param q vector of quantiles
##' @param a the shape parameter of the inverse gamma distribution
##' @param b the scale parameter of the inverse gamma distribution
##' @param lower.tail logical; if TRUE (default), probabilities are `P(X  > x)`,
##'   otherwise, `P(X <= x)`.
##' @param log.p if TRUE, probabilities/densities p are returned as `log(p)`
##'
##' @keywords internal
pinvGamma <- function(q, a, b, lower.tail = TRUE, log.p = FALSE) {
  pgamma(
    q = 1 / q,
    shape = a,
    rate = b,
    lower.tail = !lower.tail,
    log.p = log.p
  )
}

##' Compute the quantile function of Inverse gamma distribution
##' @param p vector of probabilities
##' @param a the shape parameter of the inverse gamma distribution
##' @param b the scale parameter of the inverse gamma distribution
##' @param lower.tail logical; if TRUE (default), probabilities are `P(X  > x)`,
##'   otherwise, `P(X <= x)`.
##' @param log.p FALSE if TRUE, probabilities/densities p are returned as `log(p)`
##'
##' @keywords internal
qinvGamma <- function(p, a, b, lower.tail = TRUE, log.p = FALSE) {
  1 /
    qgamma(
      p = p,
      shape = a,
      rate = b,
      lower.tail = !lower.tail,
      log.p = log.p
    )
}
##' The random generation of the Inverse gamma distribution
##' @param n the number of observations
##' @param a the shape parameter of the inverse gamma distribution
##' @param b the scale parameter of the inverse gamma distribution
##'
##' @keywords internal
rinvGamma <- function(n, a, b) {
  1 / rgamma(n, shape = a, rate = b)
}

# nolint end

#' Combining S4 Class Validation Results
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that combines two outputs from calls to `result()`
#'   function which is placed in a slot of [Validate()] reference class.
#'
#' @param v1 (`logical` or `character`)\cr an output from `result()` function from
#'   [Validate()] reference class, to be combined with `v2`.
#' @param v2 (`logical` or `character`)\cr an output from `result()` function from
#'   [Validate()] reference class, to be combined with `v1`.
#'
#' @export
#' @examples
#' h_validate_combine_results(TRUE, "some_message")
h_validate_combine_results <- function(v1, v2) {
  assert_true(
    test_true(v1) || test_character(v1, any.missing = FALSE, min.len = 1L)
  )
  assert_true(
    test_true(v2) || test_character(v2, any.missing = FALSE, min.len = 1L)
  )

  isTRUEv2 <- isTRUE(v2)
  if (isTRUE(v1)) {
    if (isTRUEv2) {
      TRUE
    } else {
      v2
    }
  } else {
    if (isTRUEv2) {
      v1
    } else {
      c(v1, v2)
    }
  }
}

#' Comparison with Numerical Tolerance and Without Name Comparison
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function ensures a default tolerance level equal to `1e-10`,
#' and ignores names and other attributes.
#' In contrast to [all.equal()], it always returns a logical type object.
#'
#' @param target (`numeric`)\cr target values.
#' @param current (`numeric`)\cr current values.
#' @param tolerance (`number`) relative differences smaller than this are not
#'   reported.
#' @return `TRUE` when `target` and `current` do not differ
#'   up to desired tolerance and without looking at names or other attributes,
#'   `FALSE` otherwise.
#'
#' @export
#'
h_all_equivalent <- function(target, current, tolerance = 1e-10) {
  assert_numeric(target)
  assert_numeric(current)
  assert_number(tolerance)

  tmp <- all.equal(
    target = target,
    current = current,
    tolerance = tolerance,
    check.names = FALSE,
    check.attributes = FALSE
  )
  isTRUE(tmp)
}

#' Preparing Data for Plotting
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function prepares a `data.frame` object based on `Data` class
#' object. The resulting data frame is used by the plot function for `Data`
#' class objects.
#'
#' @param data (`Data`)\cr object from which data is extracted and converted
#'   into a data frame.
#' @param blind (`flag`)\cr should data be blinded?
#'   If `TRUE`, then for each cohort, all DLTs are assigned to the first
#'   subjects in the cohort. In addition, the placebo (if any) is set to the
#'   active dose level for that cohort.
#' @param ... further arguments passed to `data.frame` constructor.
#'   It can be e.g. an extra `column_name = value` pair based on a slot
#'   from `x` (which in this case might be a subclass of `Data`)
#'   which does not appear in `Data`.
#' @return A [`data.frame`] object with values to plot.
#'
h_plot_data_df <- function(data, blind = FALSE, ...) {
  df <- data.frame(
    patient = seq_along(data@x),
    ID = paste(" ", data@ID),
    cohort = data@cohort,
    dose = data@x,
    toxicity = ifelse(data@y == 1, "Yes", "No"),
    ...
  )

  if (blind) {
    # This is to blind the data.
    # For each cohort, all DLTs are assigned to the first subjects in the cohort.
    # In addition, the placebo (if any) is set to the active dose level for that
    # cohort.
    # Notice: dapply reorders records of df according to the lexicographic order
    # of cohort.
    df <- dapply(df, f = ~cohort, FUN = function(coh) {
      coh$toxicity <- sort(coh$toxicity, decreasing = TRUE)
      coh$dose <- max(coh$dose)
      coh
    })
  } else if (data@placebo) {
    # Placebo will be plotted at y = 0 level.
    df$dose[df$dose == data@doseGrid[1]] <- 0
  }

  df
}

#' Preparing Cohort Lines for Data Plot
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function prepares a `ggplot` geom with reference lines
#' separating different cohorts on the plot of `Data` class object.
#' Lines are either vertical or horizontal of green color and longdash type.
#'
#' @details The geom object is returned if and only if `placebo` is equal to
#'   `TRUE` and there are more than one unique values in `cohort`. Otherwise,
#'   this function returns `NULL` object.
#'
#' @param cohort (`integer`)\cr the cohort indices.
#' @param placebo (`flag`)\cr is placebo included in the doses?
#'   If it so, this function returns `NULL` object as in this case all doses
#'   in a given cohort are equal and there is no need to separate them.
#' @param vertical (`flag`)\cr should the line be vertical? Otherwise it is
#'   horizontal.
#'
h_plot_data_cohort_lines <- function(cohort, placebo, vertical = TRUE) {
  assert_integer(cohort)
  assert_flag(placebo)
  assert_flag(vertical)

  # If feasible, add vertical or horizontal green lines separating sub-sequent
  # cohorts.
  if (placebo && length(unique(cohort)) > 1) {
    intercept <- head(cumsum(table(cohort)), n = -1) + 0.5
    if (vertical) {
      geom_vline(
        xintercept = intercept,
        colour = "green",
        linetype = "longdash"
      ) # nolintr
    } else {
      geom_hline(
        yintercept = intercept,
        colour = "green",
        linetype = "longdash"
      ) # nolintr
    }
  } else {
    NULL
  }
}

#' Checking Formals of a Function
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function checks whether a given function `fun` has required or
#' allowed arguments. The argument check is based only on the names of the
#' arguments. No any further logic is verified here.
#'
#' @param fun (`function`)\cr a function name whose argument names will be
#'   checked.
#' @param mandatory (`character` or `NULL`)\cr the names of the arguments which
#'   must be present in `fun`. If `mandatory` is specified as `NULL` (default)
#'   this requirement is ignored.
#' @param allowed (`character` or `NULL`)\cr the names of the arguments which
#'   are allowed in `fun`. Names that do not belong to `allowed` are simply not
#'   allowed. The `allowed` parameter is independent from the `mandatory`, in a
#'   sense that if `mandatory` is specified as a `character` vector, it does not
#'   have to be repeated in `allowed`. If `allowed` is specified as `NULL`
#'   (default), then it means that there must be no any arguments in `fun`
#'   (except these ones which are specified in `mandatory`).
#'
#' @export
#'
h_check_fun_formals <- function(fun, mandatory = NULL, allowed = NULL) {
  assert_function(fun)
  assert_character(mandatory, null.ok = TRUE)
  assert_character(allowed, null.ok = TRUE)

  arg_names <- names(formals(fun))
  mandatory_check <- all(mandatory %in% arg_names)
  allowed_check <- all(arg_names %in% c(mandatory, allowed))

  mandatory_check && allowed_check
}

#' Getting the Slots from a S4 Object
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function extracts requested slots from the S4 class object.
#' It is a simple wrapper of [methods::slot()] function.
#'
#' @param object (`S4`)\cr an object from a formally defined S4 class.
#' @param names (`character`)\cr a vector with names of slots to be fetched.
#'   This function assumes that for every element in `names`, there exists a
#'   slot of the same name in the `object`.
#' @param simplify (`flag`)\cr should an output be simplified? This has an
#'   effect if and only if a single slot is about to be extracted, i.e.
#'   `names` is just a single string.
#'
#' @return `list` with the slots extracted from `object` according to `names`,
#'   or single slot if simplification is required and possible.
#'
#' @export
#'
h_slots <- function(object, names, simplify = FALSE) {
  assert_true(isS4(object))
  assert_character(names, any.missing = FALSE, null.ok = TRUE)
  assert_true(all(names %in% slotNames(object)))

  if (is.null(names) || length(names) == 0L) {
    return(list())
  }

  slots_list <- sapply(
    names,
    function(n) slot(object, n),
    simplify = FALSE,
    USE.NAMES = TRUE
  )

  if (simplify && length(names) == 1) {
    slots_list[[1]]
  } else {
    slots_list
  }
}

#' Conditional Formatting Using C-style Formats
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function conditionally formats a number with [formatC()]
#' function using `"E"` format and specific number of digits as given by the
#' user. A number is formatted if and only if its absolute value is less than
#' `0.001` or greater than `10000`. Otherwise, the number is not formatted.
#' Additionally, custom prefix or suffix can be appended to character string
#' with formatted number, so that the changes are marked.
#'
#' @note This function was primarily designed as a helper for
#'   [h_jags_write_model()] function.
#'
#' @param x (`number`)\cr a number to be formatted.
#' @param digits (`function`)\cr the desired number of significant digits.
#' @param prefix (`string`)\cr a prefix to be added in front of the formatted
#'   number.
#' @param suffix (`string`)\cr a suffix to be appended after the formatted
#'   number.
#'
#' @return Either formatted `x` as `string` or unchanged `x` if the
#'   formatting condition is not met.
#'
#' @export
#' @examples
#' h_format_number(50000)
#' h_format_number(50000, prefix = "P", suffix = "S")
h_format_number <- function(x, digits = 5, prefix = "", suffix = "") {
  assert_number(x)
  assert_int(digits)
  assert_string(prefix)
  assert_string(suffix)

  if ((abs(x) < 1e-3) || (abs(x) > 1e+4)) {
    paste0(prefix, formatC(x, digits = digits, format = "E"), suffix)
  } else {
    x
  }
}

#' Recursively Apply a Function to a List
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function recursively iterates through a "list-like" object and it
#' checks whether an element is of a given class. If it so, then it replaces
#' that element by the result of an execution of a given function. Otherwise,
#' and if the element is of length greater than 1 (i.e. not a scalar), it
#' replaces that element by the result of `h_rapply()`, recursively called for
#' that element. In the remaining case, that is, the element is not of a given
#' class and is a scalar, then that element remains unchanged.
#'
#' @note This helper function is conceptually similar the same as [rapply()]
#'   function. However, it differs from [rapply()] in two major ways. First, the
#'   `h_rapply()` is not limited to objects of type `list` or `expression` only.
#'   It can be any "list-like" object of any type for which subsetting operator
#'   [`[[`][Extract] is defined. This can be, for example, an object of type
#'   `language`, often obtained from the [body()] function. The second
#'   difference is that the flexibility of [rapply()] on how the result is
#'   structured is not available with `h_rapply()` for the user. That is, with
#'   `h_rapply()` each element of `x`, which has a class included in `classes`,
#'   is replaced by the result of applying `fun` to the element. This behavior
#'   corresponds to [rapply()] when invoked with fixed `how = replace`.
#'   This function was primarily designed as a helper for [h_jags_write_model()]
#'   function.
#'
#' @param x (`any`)\cr "list-like" object for which subsetting operator
#'   [`[[`][Extract] is defined.
#' @param fun (`function`)\cr a function of one "principal" argument, passing
#'   further arguments via `...`.
#' @param classes (`character`)\cr class names.
#' @param ... further arguments passed to function `fun`.
#'
#' @return "list-like" object of similar structure as `x`.
#'
#' @export
#' @example examples/helpers-rapply.R
#'
h_rapply <- function(x, fun, classes, ...) {
  assert_function(fun)
  assert_character(classes, min.len = 1L)
  # To assert that `x` is subsettable.
  # If it works, fine, we don't see the result, otherwise it gives the error.
  force(x[[1]])

  for (i in seq_along(x)) {
    if (class(x[[i]]) %in% classes) {
      x[[i]] <- do.call(fun, c(list(x[[i]]), ...))
    } else if (length(x[[i]]) > 1L) {
      x[[i]] <- h_rapply(x[[i]], fun, classes, ...)
    }
  }
  x
}

#' Getting `NULL` for `NA`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that replaces `NA` object by `NULL` object.
#'
#' @param x (`any`)\cr atomic object of length `1`. For the definition of
#'   "atomic", see [is.atomic()].
#'
#' @return `NULL` if `x` is `NA`, otherwise, `x`.
#'
#' @export
#' @examples
#' h_null_if_na(NA)
h_null_if_na <- function(x) {
  assert_atomic(x, len = 1L)

  if (is.na(x)) {
    NULL
  } else {
    x
  }
}

#' Getting the default value for an empty object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that sets a default value for an empty or missing object,
#' that is an object for which [length()] function returns `0L` or it has length 1
#' and [is.na()] returns `TRUE`.
#'
#' @param x (`any`) \cr an object to handle. It can be any object for which
#'   [length()] function is defined.
#' @param default (`any`) \cr a default value for `x` object.
#'
#' @export
#' @examples
#' h_default_if_empty(character(0), default = "default label")
#' h_default_if_empty("custom label", default = "default label")
#' h_default_if_empty(NA, default = "default label")
h_default_if_empty <- function(x, default) {
  if (length(x) == 0L || (length(x) == 1L && is.na(x))) {
    default
  } else {
    x
  }
}
#' Testing Matrix for Positive Definiteness
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function checks whether a given numerical matrix `x` is a
#' positive-definite square matrix of a given size, without any missing
#' values. This function is used to test if a given matrix is a covariance
#' matrix, since every symmetric positive semi-definite matrix is a covariance
#' matrix.
#'
#' @details The positive definiteness test implemented in this function
#'   is based on the following characterization valid for real matrices:
#'   `A symmetric matrix is positive-definite if and only if all of its
#'   eigenvalues are positive.` In this function an eigenvalue is considered
#'   as positive if and only if it is greater than the `tol`.
#'
#' @param x (`matrix`)\cr a matrix to be checked.
#' @param size (`integer`)\cr a size of the square matrix `x` to be checked
#'   against for.
#' @param tol (`number`)\cr a given tolerance number used to check whether
#'   an eigenvalue is positive or not. An eigenvalue is considered
#'   as positive if and only if it is greater than the `tol`.
#'
#' @return `TRUE` if a given matrix is a positive-definite, `FALSE` otherwise.
#'
#' @export
#'
h_is_positive_definite <- function(x, size = 2, tol = 1e-08) {
  assert_number(tol)

  is_matrix <- test_matrix(
    x,
    mode = "numeric",
    nrows = size,
    ncols = size,
    any.missing = FALSE
  )

  if (is_matrix) {
    is_symmetric <- all.equal(x, t(x), tolerance = tol)
    if (isTRUE(is_symmetric)) {
      ev <- eigen(x, only.values = TRUE)$values
      all(ev > tol)
    } else {
      FALSE
    }
  } else {
    FALSE
  }
}

#' Check that an argument is a named vector of type numeric
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that tests whether an object is a named numerical
#' vector.
#'
#' @note This function is based on [`checkmate::test_numeric()`] and
#'   [`checkmate::test_names()`] functions.
#'
#' @param x (`any`)\cr object to check.
#' @inheritParams checkmate::test_names
#' @inheritParams checkmate::test_numeric
#' @param ... further parameters passed to [`checkmate::test_numeric()`].
#'
#' @return `TRUE` if `x` is a named vector of type numeric, otherwise `FALSE`.
#'
#' @export
#' @examples
#' h_test_named_numeric(1:2, permutation.of = c("a", "b"))
#' h_test_named_numeric(c(a = 1, b = 2), permutation.of = c("a", "b"))
#' h_test_named_numeric(c(a = 1, b = 2), permutation.of = c("b", "a"))
h_test_named_numeric <- function(
  x,
  subset.of = NULL, # nolintr
  must.include = NULL, # nolintr
  permutation.of = NULL, # nolintr
  identical.to = NULL, # nolintr
  disjunct.from = NULL, # nolintr
  lower = 0 + .Machine$double.xmin,
  finite = TRUE,
  any.missing = FALSE, # nolintr
  len = 2,
  ...
) {
  is_valid_num <- test_numeric(
    x,
    lower = lower,
    finite = finite,
    any.missing = any.missing,
    len = len,
    ...,
    names = "named"
  )
  are_names_valid <- test_names(
    names(x),
    subset.of = subset.of,
    must.include = must.include,
    permutation.of = permutation.of,
    identical.to = identical.to,
    disjunct.from = disjunct.from,
  )
  is_valid_num && are_names_valid
}

#' Check which elements are in a given range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that tests whether elements of a given vector or
#' matrix are within specified interval.
#'
#' @param x (`numeric`)\cr vector or matrix with elements to test.
#' @param range (`numeric`)\cr an interval, i.e. sorted two-elements vector.
#' @param bounds_closed (`logical`)\cr should bounds in the `range` be treated
#'   as closed? This can be a scalar or vector of length two. If it is a scalar,
#'   then its value applies to lower bound `range[1]` and upper bound
#'   `range[2]`. If this is a vector with two flags, the first flag corresponds
#'   to the lower bound only, and the second to the upper bound only.
#'
#' @return A logical vector or matrix of length equal to the length of `x`, that
#'   for every element of `x`, indicates whether a given element of `x` is in
#'   the `range`.
#'
#' @export
#' @examples
#' x <- 1:4
#' h_in_range(x, range = c(1, 3))
#' h_in_range(x, range = c(1, 3), bounds_closed = FALSE)
#' h_in_range(x, range = c(1, 3), bounds_closed = c(FALSE, TRUE))
#' mat <- matrix(c(2, 5, 3, 10, 4, 9, 1, 8, 7), nrow = 3)
#' h_in_range(mat, range = c(1, 5))
h_in_range <- function(x, range = c(0, 1), bounds_closed = TRUE) {
  assert_numeric(x)
  assert_numeric(range, any.missing = FALSE, len = 2, sorted = TRUE)
  assert_logical(bounds_closed, min.len = 1, max.len = 2, any.missing = FALSE)

  above_lwr <- if (bounds_closed[1]) {
    x >= range[1]
  } else {
    x > range[1]
  }

  below_upr <- if (tail(bounds_closed, 1)) {
    x <= range[2]
  } else {
    x < range[2]
  }

  above_lwr & below_upr
}

#' Find Interval Numbers or Indices and Return Custom Number For 0.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple wrapper of [`findInterval()`] function that invokes
#' [`findInterval()`], takes its output and replaces all the
#' elements with \eqn{0} value to a custom number as specified in `replacement`
#' argument.
#'
#' @inheritDotParams base::findInterval
#' @param replacement (`number`)\cr a custom number to be used as a replacement
#'   for \eqn{0}. Default to `-Inf`.
#'
#' @export
#' @examples
#' h_find_interval(1, c(2, 4, 6))
#' h_find_interval(3, c(2, 4, 6))
#' h_find_interval(1, c(2, 4, 6), replacement = -1)
h_find_interval <- function(..., replacement = -Inf) {
  assert_number(replacement)

  x <- findInterval(...)
  ifelse(x == 0, yes = replacement, no = x)
}


#' Group Together Mono and Combo Data
#'
#' This is only used in the simulation method for `DesignGrouped` to combine
#' the separately generated data sets from mono and combo arms and to fit the
#' combined logistic regression model.
#' Hence the ID and cohort information is not relevant and will be
#' arbitrarily assigned to avoid problems with the [`DataGrouped`] validation.
#'
#' @param mono_data (`Data`)\cr mono data.
#' @param combo_data (`Data`)\cr combo data.
#'
#' @return A [`DataGrouped`] object containing both `mono_data` and `combo_data`,
#'   but with arbitrary ID and cohort slots.
#'
#' @keywords internal
h_group_data <- function(mono_data, combo_data) {
  assert_class(mono_data, "Data")
  assert_class(combo_data, "Data")

  df <- data.frame(
    x = c(mono_data@x, combo_data@x),
    y = c(mono_data@y, combo_data@y),
    group = rep(
      c("mono", "combo"),
      c(length(mono_data@x), length(combo_data@x))
    )
  )
  df <- df[order(df$x), ]

  DataGrouped(
    x = df$x,
    y = df$y,
    ID = seq_along(df$x),
    cohort = as.integer(factor(df$x)),
    doseGrid = sort(unique(c(mono_data@doseGrid, combo_data@doseGrid))),
    group = df$group
  )
}

#' Internal Helper Functions for Validation of [`GeneralModel`] and [`ModelPseudo`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`GeneralModel`] and [`ModelPseudo`] or inherited classes and therefore are
#' not exported.
#'
#' @name v_model_objects
#' @param object (`GeneralModel`) or (`ModelPseudo`) \cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_model_objects validates that the names of the
#'   arguments in `init` function are included in `datanames` or `datanames_prior`
#'   slots.
v_general_model <- function(object) {
  v <- Validate()
  v$check(
    h_check_fun_formals(
      object@init,
      allowed = union(object@datanames, object@datanames_prior)
    ),
    "Arguments of the init function must be data names"
  )
  v$result()
}

#' @describeIn v_model_objects validates that the logistic Kadane model
#'   parameters are valid.
v_model_logistic_kadane <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@theta, bounds_closed = FALSE),
    "theta must be a probability scalar > 0 and < 1"
  )
  is_xmin_number <- test_number(object@xmin)
  v$check(is_xmin_number, "xmin must be scalar")

  is_xmax_number <- test_number(object@xmax)
  v$check(is_xmax_number, "xmax must be scalar")

  if (is_xmin_number && is_xmax_number) {
    v$check(
      object@xmin < object@xmax,
      "xmin must be strictly smaller than xmax"
    )
  }
  v$result()
}

#' @describeIn v_model_objects validates that the logistic Kadane model
#'   parameters with a beta and gamma prior are valid.
v_model_logistic_kadane_beta_gamma <- function(object) {
  # nolintr
  v <- Validate()
  v$check(
    test_number(object@alpha, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter alpha must be a positive scalar"
  )
  v$check(
    test_number(object@beta, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter beta must be a positive scalar"
  )
  v$check(
    test_number(object@shape, lower = .Machine$double.xmin, finite = TRUE),
    "Gamma distribution shape parameter must be a positive scalar"
  )
  v$check(
    test_number(object@rate, lower = .Machine$double.xmin, finite = TRUE),
    "Gamma distribution rate parameter must be a positive scalar"
  )
  v$result()
}

#' @describeIn v_model_objects validates that `weightpar` is valid.
v_model_logistic_normal_mix <- function(object) {
  v <- Validate()
  v$check(
    h_test_named_numeric(object@weightpar, permutation.of = c("a", "b")),
    "weightpar must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
  )
  v$result()
}

#' @describeIn v_model_objects validates that `component` is a list with
#'   valid `ModelParamsNormal` objects as well as `weights` are correct.
v_model_logistic_normal_fixed_mix <- function(object) {
  # nolintr
  v <- Validate()
  v$check(
    all(sapply(object@components, test_class, "ModelParamsNormal")),
    "components must be a list with ModelParamsNormal S4 class objects"
  )
  comp_valid_result <- sapply(object@components, validObject, test = TRUE)
  comp_valid <- sapply(comp_valid_result, isTRUE)
  v$check(
    all(comp_valid),
    paste(
      "components must be a list with valid ModelParamsNormal S4 class objects",
      paste(unlist(comp_valid_result[!comp_valid]), collapse = ", "),
      collapse = ", ",
      sep = ", "
    )
  )
  v$check(
    length(object@components) == length(object@weights),
    "components must have same length as weights"
  )
  v$check(
    test_numeric(
      object@weights,
      lower = .Machine$double.xmin,
      finite = TRUE,
      any.missing = FALSE
    ),
    "weights must be positive"
  )
  v$check(
    sum(object@weights) == 1,
    "weights must sum to 1"
  )
  v$check(
    test_flag(object@log_normal),
    "log_normal must be TRUE or FALSE"
  )
  v$result()
}

#' @describeIn v_model_objects validates that `share_weight` represents probability.
v_model_logistic_log_normal_mix <- function(object) {
  # nolintr
  v <- Validate()
  v$check(
    test_probability(object@share_weight),
    "share_weight does not specify a probability"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpoint`] class slots are valid.
v_model_dual_endpoint <- function(object) {
  rmin <- .Machine$double.xmin
  v <- Validate()

  v$check(
    test_flag(object@use_log_dose),
    "use_log_dose must be TRUE or FALSE"
  )
  uf_sigma2W <- object@use_fixed["sigma2W"] # nolintr
  v$check(
    test_flag(uf_sigma2W),
    "use_fixed must be a named logical vector that contains name 'sigma2W'"
  )
  uf_rho <- object@use_fixed["rho"]
  v$check(
    test_flag(uf_rho),
    "use_fixed must be a named logical vector that contains name 'rho'"
  )

  if (isTRUE(uf_sigma2W)) {
    v$check(
      test_number(object@sigma2W, lower = rmin, finite = TRUE),
      "sigma2W must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2W is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2W, permutation.of = c("a", "b")),
      "sigma2W must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }

  if (isTRUE(uf_rho)) {
    v$check(
      test_number(object@rho, lower = -1 + rmin, upper = 1 - rmin), # rmin is ignored here!
      "rho must be a number in (-1, 1)"
    )
  } else {
    # object@rho is a vector with parameters for Beta(a, b).
    v$check(
      h_test_named_numeric(object@rho, permutation.of = c("a", "b")),
      "rho must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }

  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpointRW`] class slots are valid.
v_model_dual_endpoint_rw <- function(object) {
  v <- Validate()
  uf_sigma2W <- object@use_fixed["sigma2betaW"] # nolintr
  v$check(
    test_flag(uf_sigma2W),
    "use_fixed must be a named logical vector that contains name 'sigma2betaW'"
  )
  if (isTRUE(uf_sigma2W)) {
    v$check(
      test_number(
        object@sigma2betaW,
        lower = .Machine$double.xmin,
        finite = TRUE
      ),
      "sigma2betaW must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2betaW is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2betaW, permutation.of = c("a", "b")),
      "sigma2betaW must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }
  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpointBeta`] class slots are valid.
v_model_dual_endpoint_beta <- function(object) {
  v <- Validate()

  for (s in c("E0", "Emax", "delta1", "mode")) {
    rmin <- .Machine$double.xmin
    uf <- object@use_fixed[s]

    v$check(
      test_flag(uf),
      paste0(
        "use_fixed must be a named logical vector that contains name '",
        s,
        "'"
      )
    )
    if (isTRUE(uf)) {
      if (s %in% c("delta1", "mode")) {
        v$check(
          test_number(slot(object, s), lower = rmin, finite = TRUE),
          paste(s, "must be a positive and finite numerical scalar")
        )
      }
    } else {
      # s is a vector with parameters for Uniform(s[1], s[2]) prior.
      v$check(
        test_numeric(
          slot(object, s),
          lower = 0,
          finite = TRUE,
          any.missing = FALSE,
          len = 2,
          unique = TRUE,
          sorted = TRUE
        ),
        paste(
          s,
          "must be a numerical vector of length two with non-negative, finite, unique and sorted (asc.) values"
        )
      )
    }
  }

  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpointEmax`] class slots are valid.
v_model_dual_endpoint_emax <- function(object) {
  v <- Validate()

  for (s in c("E0", "Emax", "ED50")) {
    rmin <- .Machine$double.xmin
    uf <- object@use_fixed[s]

    v$check(
      test_flag(uf),
      paste0(
        "use_fixed must be a named logical vector that contains name '",
        s,
        "'"
      )
    )
    if (isTRUE(uf)) {
      v$check(
        test_number(slot(object, s), lower = rmin, finite = TRUE),
        paste(s, "must be a positive and finite numerical scalar")
      )
    } else {
      # s is a vector with parameters for Uniform(s[1], s[2]) prior.
      v$check(
        test_numeric(
          slot(object, s),
          lower = 0,
          finite = TRUE,
          any.missing = FALSE,
          len = 2,
          unique = TRUE,
          sorted = TRUE
        ),
        paste(
          s,
          "must be a numerical vector of length two with non-negative, finite, unique and sorted (asc.) values"
        )
      )
    }
  }

  v$result()
}

#' @describeIn v_model_objects validates that [`LogisticIndepBeta`] class slots are valid.
v_model_logistic_indep_beta <- function(object) {
  v <- Validate()

  dle_len <- length(object@binDLE)
  v$check(
    test_numeric(
      object@binDLE,
      finite = TRUE,
      any.missing = FALSE,
      min.len = 2
    ),
    "binDLE must be a finite numerical vector of minimum length 2, without missing values"
  )
  v$check(
    test_numeric(
      object@DLEdose,
      finite = TRUE,
      any.missing = FALSE,
      len = dle_len
    ),
    "DLEdose must be a finite numerical vector of the same length as 'binDLE', without missing values"
  )
  v$check(
    test_integer(object@DLEweights, any.missing = FALSE, len = dle_len),
    "DLEweights must be an integer vector of the same length as 'binDLE', without missing values"
  )
  v$check(
    test_number(object@phi1),
    "phi1 must be a numerical scalar"
  )
  v$check(
    test_number(object@phi2),
    "phi2 must be a numerical scalar"
  )
  v$check(
    h_is_positive_definite(object@Pcov),
    "Pcov must be 2x2 positive-definite matrix without any missing values"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`Effloglog`] class slots are valid.
v_model_eff_log_log <- function(object) {
  rmin <- .Machine$double.xmin

  v <- Validate()
  v$check(
    test_numeric(object@eff, finite = TRUE, any.missing = FALSE, min.len = 2),
    "eff must be a finite numerical vector of minimum length 2, without missing values"
  )
  eff_dose_ok <- test_numeric(
    object@eff_dose,
    lower = rmin,
    finite = TRUE,
    any.missing = FALSE,
    len = length(object@eff)
  )
  v$check(
    eff_dose_ok,
    "eff_dose must be a finite numerical vector of the same length as 'eff', without missing values"
  )
  v$check(
    test_flag(object@use_fixed),
    "use_fixed must be a flag"
  )
  if (isTRUE(object@use_fixed)) {
    v$check(
      test_number(object@nu, lower = rmin, finite = TRUE),
      "nu must be a positive and finite numerical scalar"
    )
  } else {
    # object@nu is a vector with parameters for Gamma(a, b).
    v$check(
      h_test_named_numeric(object@nu, permutation.of = c("a", "b")),
      "nu must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }
  const_ok <- test_number(object@const, lower = 0)
  v$check(const_ok, "const must be a non-negative number")
  if (eff_dose_ok && const_ok) {
    v$check(
      min(object@data@doseGrid, object@eff_dose) > 1 - object@const,
      "For log-log model, doses and const must be such that dose + const > 1"
    )
  }
  v$check(
    test_number(object@theta1),
    "theta1 must be a numerical scalar"
  )
  v$check(
    test_number(object@theta2),
    "theta2 must be a numerical scalar"
  )
  nobs_no_dlt <- sum(!object@data@y)
  if (nobs_no_dlt + length(object@eff) > 2) {
    v$check(
      h_is_positive_definite(object@Pcov),
      "Pcov must be 2x2 positive-definite matrix without any missing values"
    )
  } else {
    v$check(
      test_matrix(object@Pcov, mode = "numeric", nrows = 2, ncols = 2) &&
        all(is.na(object@Pcov)),
      "Pcov must be 2x2 numeric matrix with all values missing if the length of combined data is 2"
    )
  }
  v$check(
    test_numeric(object@mu, finite = TRUE, len = 2),
    "mu must be a finite numerical vector of length 2"
  )
  Xnrow <- ifelse(nobs_no_dlt > 0, nobs_no_dlt, length(object@eff_dose))
  v$check(
    test_matrix(
      object@X,
      mode = "numeric",
      nrows = Xnrow,
      ncols = 2,
      any.missing = FALSE
    ),
    paste(
      "X must be a finite numerical matrix of size",
      Xnrow,
      "x 2, without any missing values"
    )
  )
  v$check(
    all(object@X[, 1] == 1),
    "X must be a design matrix, i.e. first column must be of 1s"
  )
  v$check(
    h_is_positive_definite(object@Q),
    "Q must be 2x2 positive-definite matrix without any missing values"
  )
  v$check(
    test_numeric(object@Y, finite = TRUE, any.missing = FALSE, len = Xnrow),
    paste(
      "Y must be a finite numerical vector of length",
      Xnrow,
      "and without any missing values"
    )
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`EffFlexi`] class slots are valid.
v_model_eff_flexi <- function(object) {
  rmin <- .Machine$double.xmin

  v <- Validate()
  v$check(
    test_numeric(object@eff, finite = TRUE, any.missing = FALSE, min.len = 2),
    "eff must be a finite numerical vector of minimum length 2, without missing values"
  )
  v$check(
    test_numeric(
      object@eff_dose,
      lower = rmin,
      finite = TRUE,
      any.missing = FALSE,
      len = length(object@eff)
    ),
    "eff_dose must be a finite numerical vector of the same length as 'eff', without missing values"
  )

  uf_sigma2W <- object@use_fixed["sigma2W"] # nolintr
  v$check(
    test_flag(uf_sigma2W),
    "use_fixed must be a named logical vector that contains name 'sigma2W'"
  )
  uf_sigma2betaW <- object@use_fixed["sigma2betaW"] # nolintr
  v$check(
    test_flag(uf_sigma2betaW),
    "use_fixed must be a named logical vector that contains name 'sigma2betaW'"
  )

  if (isTRUE(uf_sigma2W)) {
    v$check(
      test_number(object@sigma2W, lower = rmin, finite = TRUE),
      "sigma2W must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2W is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2W, permutation.of = c("a", "b")),
      "sigma2W must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }
  if (isTRUE(uf_sigma2betaW)) {
    v$check(
      test_number(object@sigma2betaW, lower = rmin, finite = TRUE),
      "sigma2betaW must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2betaW is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2betaW, permutation.of = c("a", "b")),
      "sigma2betaW must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }

  v$check(
    test_flag(object@rw1),
    "rw1 must be a flag"
  )
  v$check(
    test_matrix(
      object@X,
      mode = "integer",
      ncols = object@data@nGrid,
      any.missing = FALSE
    ),
    paste(
      "X must be an integer matrix with",
      object@data@nGrid,
      "columns and without any missing values"
    )
  )
  v$check(
    all(object@X == 0L | object@X == 1L),
    "X must be a matrix with 0-1 values only"
  )
  v$check(
    test_matrix(
      object@RW,
      nrows = object@data@nGrid,
      ncols = object@data@nGrid,
      any.missing = FALSE
    ),
    paste0(
      "RW must be ",
      object@data@nGrid,
      "x",
      object@data@nGrid,
      " matrix without any missing values"
    )
  )
  v$check(
    test_int(object@RW_rank) &&
      (object@RW_rank ==
        (object@data@nGrid - ifelse(isTRUE(object@rw1), 1L, 2L))),
    "RW_rank must be an integer equal to data@nGrid - 2L"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`DALogisticLogNormal`] class slots are valid.
v_model_da_logistic_log_normal <- function(object) {
  v <- Validate()

  npiece_ok <- test_int(object@npiece)
  v$check(npiece_ok, "npiece must be a is a single integerish value")
  if (npiece_ok) {
    v$check(
      test_numeric(
        object@l,
        lower = 0,
        finite = TRUE,
        any.missing = FALSE,
        len = object@npiece
      ),
      "prior parameter vector l of lambda must be a non-negative vector of length equal to npiece"
    )
  }
  v$check(
    test_number(object@c_par, finite = TRUE),
    "c_par must be a finite numerical scalar"
  )
  v$check(
    test_flag(object@cond_pem),
    "cond_pem must be a flag"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`TITELogisticLogNormal`] class slots are valid.
v_model_tite_logistic_log_normal <- function(object) {
  # nolintr
  v <- Validate()
  v$check(
    test_string(object@weight_method, pattern = "^linear$|^adaptive$"),
    "weight_method must be a string equal either to linear or adaptive"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`OneParLogNormalPrior`] class slots are valid.
v_model_one_par_exp_normal_prior <- function(object) {
  # nolintr
  v <- Validate()

  is_skel_prob_ok <- test_probabilities(
    object@skel_probs,
    unique = TRUE,
    sorted = TRUE
  )
  v$check(
    is_skel_prob_ok,
    "skel_probs must be a unique sorted probability values between 0 and 1"
  )

  if (is_skel_prob_ok) {
    # Validating skel_fun/skel_fun_inv on within the range of skeleton probs.
    skel_probs_range <- range(object@skel_probs)
    # Probabilities within the range of skel_probs.
    probs_in_range <- seq(
      from = skel_probs_range[1],
      to = skel_probs_range[2],
      by = 0.01
    )
    # Interpolated dose grid.
    doses_in_range <- object@skel_fun_inv(probs_in_range)
    v$check(
      isTRUE(all.equal(object@skel_fun(doses_in_range), probs_in_range)),
      "skel_fun_inv must be an inverse funtion of skel_fun function on within the range of sekeleton probs"
    )

    # Validating skel_fun/skel_fun_inv on outside the range of skeleton probs.
    probs_out_range <- c(
      seq(from = 0, to = skel_probs_range[1], length.out = 3),
      seq(from = skel_probs_range[2], to = 1, length.out = 3)
    )
    doses_out_range <- object@skel_fun_inv(probs_out_range)
    v$check(
      isTRUE(all.equal(
        object@skel_fun(doses_out_range),
        rep(skel_probs_range, each = 3)
      )),
      "skel_fun_inv must be an inverse funtion of skel_fun function on outside the range of sekeleton probs"
    )
  }

  v$check(
    test_number(object@sigma2, lower = .Machine$double.xmin, finite = TRUE),
    "sigma2 must be a positive finite number"
  )

  v$result()
}

#' @describeIn v_model_objects validates that [`OneParExpPrior`] class slots are valid.
v_model_one_par_exp_prior <- function(object) {
  v <- Validate()

  is_skel_prob_ok <- test_probabilities(
    object@skel_probs,
    unique = TRUE,
    sorted = TRUE
  )
  v$check(
    is_skel_prob_ok,
    "skel_probs must be a unique sorted probability values between 0 and 1"
  )

  if (is_skel_prob_ok) {
    # Validating skel_fun/skel_fun_inv on within the range of skeleton probs.
    skel_probs_range <- range(object@skel_probs)
    # Probabilities within the range of skel_probs.
    probs_in_range <- seq(
      from = skel_probs_range[1],
      to = skel_probs_range[2],
      by = 0.01
    )
    # Interpolated dose grid.
    doses_in_range <- object@skel_fun_inv(probs_in_range)
    v$check(
      isTRUE(all.equal(object@skel_fun(doses_in_range), probs_in_range)),
      "skel_fun_inv must be an inverse funtion of skel_fun function on within the range of sekeleton probs"
    )

    # Validating skel_fun/skel_fun_inv on outside the range of skeleton probs.
    probs_out_range <- c(
      seq(from = 0, to = skel_probs_range[1], length.out = 3),
      seq(from = skel_probs_range[2], to = 1, length.out = 3)
    )
    doses_out_range <- object@skel_fun_inv(probs_out_range)
    v$check(
      isTRUE(all.equal(
        object@skel_fun(doses_out_range),
        rep(skel_probs_range, each = 3)
      )),
      "skel_fun_inv must be an inverse funtion of skel_fun function on outside the range of sekeleton probs"
    )
  }

  v$check(
    test_number(object@lambda, lower = .Machine$double.xmin, finite = TRUE),
    "lambda must be a positive finite number"
  )

  v$result()
}

#' @describeIn v_model_objects confirms that cov is diagonal
v_logisticlognormalordinal <- function(object) {
  v <- Validate()
  # diag(x) returns a vector, not a matrix, so cannot use identical(x, diag(x)
  x <- object@params@cov
  diag(x) <- rep(0, ncol(x))
  v$check(
    all(x == 0),
    "covariance matrix must be diagonal"
  )
  v$result()
}

#' @include helpers_data.R

# plot ----

## Data ----

#' Plot Method for the [`Data`] Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`Data`] object.
#'
#' @return The [`ggplot2`] object.
#'
#' @aliases plot-Data
#' @rdname plot-Data
#' @export
#' @example examples/Data-method-plot.R
#'
setMethod(
  f = "plot",
  signature = signature(x = "Data", y = "missing"),
  definition = function(x, y, blind = FALSE, legend = TRUE, ...) {
    assert_flag(blind)
    assert_flag(legend)
    h_plot_data_dataordinal(x, blind, legend, ...)
  }
)

#' Plot Method for the [`DataOrdinal`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that creates a plot for [`DataOrdinal`] object.
#'
#' @param x (`DataOrdinal`)\cr object we want to plot.
#' @param y (`missing`)\cr missing object, for compatibility with the generic
#'   function.
#' @param blind (`flag`)\cr indicates whether to blind the data.
#'   If `TRUE`, then placebo subjects are reported at the same level
#'   as the active dose level in the corresponding cohort,
#'   and DLTs are always assigned to the first subjects in a cohort.
#' @param legend (`flag`)\cr whether the legend should be added.
#' @param tox_labels (`named list of character`)\cr the labels of the toxicity
#' categories.
#' @param tox_shapes (`names list of integers`)\cr the symbols used to identify
#' the toxicity categories.
#' @param ... not used.
#'
#' @note With more than 9 toxicity categories, toxicity symbols must be
#' specified manually.\cr With more than 5 toxicity categories, toxicity labels
#' must be specified manually.
#'
#' @return The [`ggplot2`] object.
#'
#' @rdname plot-Data
#' @export
#' @example examples/DataOrdinal-method-plot.R
setMethod(
  f = "plot",
  signature = signature(x = "DataOrdinal", y = "missing"),
  definition = function(
    x,
    y,
    blind = FALSE,
    legend = TRUE,
    tox_labels = NULL,
    tox_shapes = NULL,
    ...
  ) {
    if (is.null(tox_shapes)) {
      assert_true(length(x@yCategories) <= 9)
      tox_shapes <- c(17L, 16L, 15L, 18L, 0L:2L, 5L, 6L)[seq_along(
        x@yCategories
      )]
      names(tox_shapes) <- names(x@yCategories)
    }
    if (is.null(tox_labels)) {
      assert_true(length(x@yCategories) <= 5)
      tox_labels <- switch(
        length(x@yCategories),
        c("black"),
        c("black", "red"),
        c("black", "orange", "red"),
        c("black", "green", "orange", "red"),
        c("black", "green", "yellow", "orange", "red")
      )
      names(tox_labels) <- names(x@yCategories)
    }
    h_plot_data_dataordinal(
      x,
      blind,
      legend,
      tox_labels = tox_labels,
      tox_shapes = tox_shapes,
      ...
    )
  }
)

## DataDual ----

#' Plot Method for the [`DataDual`] Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`DataDual`] object.
#'
#' @param x (`DataDual`)\cr object we want to plot.
#' @param y (`missing`)\cr missing object, for compatibility with the generic
#'   function.
#' @param blind (`flag`)\cr indicates whether to blind the data.
#'   If `TRUE`, then placebo subjects are reported at the same level
#'   as the active dose level in the corresponding cohort,
#'   and DLTs are always assigned to the first subjects in a cohort.
#' @param ... passed to the first inherited method `plot` after this current
#'   method.
#'
#' @return The [`ggplot2`] object.
#'
#' @aliases plot-DataDual
#' @export
#' @example examples/Data-method-plot-DataDual.R
#'
setMethod(
  f = "plot",
  signature = signature(x = "DataDual", y = "missing"),
  definition = function(x, y, blind = FALSE, ...) {
    assert_flag(blind)

    # Call the superclass method, to get the first plot.
    plot1 <- callNextMethod(x, blind = blind, legend = FALSE, ...)

    # Create the second, biomarker plot.
    df <- h_plot_data_df(x, blind, biomarker = x@w)

    plot2 <- ggplot(df, aes(x = dose, y = biomarker)) +
      geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +
      scale_colour_manual(
        name = "Toxicity",
        values = c(Yes = "red", No = "black")
      ) +
      scale_shape_manual(name = "Toxicity", values = c(Yes = 17, No = 16)) +
      xlab("Dose Level") +
      ylab("Biomarker")

    if (!blind) {
      plot2 <- plot2 +
        geom_text(
          aes(
            y = biomarker + 0.02 * diff(range(biomarker)),
            label = patient,
            size = 2
          ),
          data = df,
          hjust = 0,
          vjust = 0.5,
          angle = 90,
          colour = "black",
          show.legend = FALSE
        )
    }

    # Arrange both plots side by side.
    gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
  }
)

## DataDA ----

#' Plot Method for the [`DataDA`] Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`DataDA`] object.
#'
#' @param x (`DataDA`)\cr object we want to plot.
#' @param y (`missing`)\cr missing object, for compatibility with the generic
#'   function.
#' @param blind (`flag`)\cr indicates whether to blind the data.
#'   If `TRUE`, then placebo subjects are reported at the same level
#'   as the active dose level in the corresponding cohort,
#'   and DLTs are always assigned to the first subjects in a cohort.
#' @param ... passed to the first inherited method `plot` after this current
#'   method.
#'
#' @return The [`ggplot2`] object.
#'
#' @aliases plot-DataDA
#' @export
#' @example examples/Data-method-plot-DataDA.R
#'
setMethod(
  f = "plot",
  signature = signature(x = "DataDA", y = "missing"),
  definition = function(x, y, blind = FALSE, ...) {
    assert_flag(blind)

    # Call the superclass method, to get the first plot.
    plot1 <- callNextMethod(x, blind = blind, legend = FALSE, ...)

    # Prepare data set for the second, time plot.
    df <- h_plot_data_df(x, blind, u = x@u, t0 = x@t0)
    df$censored <- ifelse(df$u < x@Tmax & df$toxicity == 0, 1, 0)
    df$tend <- df$t0 + df$u # `tend` stands for `time end`
    df$t0_case <- "Start"
    df$tend_case <- ifelse(
      df$toxicity == "Yes",
      "Yes",
      ifelse(df$censored, "Censored", "No")
    )

    # Build plot object.
    plot2 <- ggplot(df, aes(x = t0, y = patient)) +
      geom_segment(aes(xend = tend, yend = patient)) +
      geom_point(aes(shape = t0_case, colour = t0_case), size = 3) +
      geom_point(
        aes(x = tend, shape = tend_case, colour = tend_case),
        size = 3
      ) +
      scale_colour_manual(
        name = "Toxicity",
        values = c(
          Yes = "red",
          No = "black",
          Start = "black",
          Censored = "black"
        )
      ) +
      scale_shape_manual(
        name = "Toxicity",
        values = c(Yes = 17, No = 16, Start = 1, Censored = 4)
      ) +
      scale_y_continuous(breaks = df$patient, minor_breaks = NULL) +
      xlab("Time") +
      ylab("Patient")

    plot2 <- plot2 +
      h_plot_data_cohort_lines(df$cohort, placebo = x@placebo, vertical = FALSE)

    if (!blind) {
      plot2 <- plot2 +
        geom_text(
          aes(label = ID, size = 2),
          size = 3,
          hjust = 1.5,
          vjust = 0,
          angle = 0,
          colour = "black",
          show.legend = FALSE
        )
    }

    # Arrange both plots side by side.
    gridExtra::arrangeGrob(plot1, plot2, ncol = 1)
  }
)

# update ----

## Data ----

#' Updating `Data` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`Data`] object with new data.
#'
#' @param object (`Data`)\cr object you want to update.
#' @param x (`number`)\cr the dose level (one level only!).
#' @param y (`integer`)\cr the DLT vector (0/1 vector) for all patients in this
#'   cohort. You can also supply `numeric` vectors, but these will then be
#'   converted to `integer` internally.
#' @param ID (`integer`)\cr the patient IDs.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param new_cohort (`flag`)\cr if `TRUE` (default) the new data are assigned
#'   to a new cohort.
#' @param check (`flag`)\cr whether the validation of the updated object should
#'   be conducted. See details below.
#' @param ... not used.
#'
#' @return The new, updated [`Data`] object.
#'
#' @details The current implementation of this `update` method allows for
#'   updating the `Data` class object by adding a single dose level `x` only.
#'   However, there might be some use cases where the new cohort to be added
#'   contains a placebo and active dose. Hence, such update would need to be
#'   performed iteratively by calling the `update` method twice. For example,
#'   in the first call a user can add a placebo, and then in the second call,
#'   an active dose. Since having a cohort with placebo only is not allowed,
#'   the `update` method would normally throw the error when attempting to add
#'   a placebo in the first call. To allow for such updates, the `check`
#'   parameter should be then set to `FALSE` for that first call.
#'
#' @aliases update-Data
#' @export
#' @example examples/Data-method-update.R
#'
setMethod(
  f = "update",
  signature = signature(object = "Data"),
  definition = function(
    object,
    x,
    y,
    ID = length(object@ID) + seq_along(y),
    new_cohort = TRUE,
    check = TRUE,
    ...
  ) {
    assert_numeric(x, min.len = 0, max.len = 1)
    assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE)
    assert_integerish(ID, len = length(y), any.missing = FALSE)
    assert_disjunct(object@ID, ID)
    assert_flag(new_cohort)
    assert_flag(check)

    # How many additional patients, ie. the length of the update.
    n <- length(y)

    # Which grid level is the dose?
    gridLevel <- match_within_tolerance(x, object@doseGrid)
    object@xLevel <- c(object@xLevel, rep(gridLevel, n))

    # Add dose.
    object@x <- c(object@x, rep(as.numeric(x), n))

    # Add DLT data.
    object@y <- c(object@y, as.integer(y))

    # Add ID.
    object@ID <- c(object@ID, as.integer(ID))

    # Add cohort number.
    new_cohort_id <- if (object@nObs == 0) {
      1L
    } else {
      tail(object@cohort, 1L) + ifelse(new_cohort, 1L, 0L)
    }
    object@cohort <- c(object@cohort, rep(new_cohort_id, n))

    # Increment sample size.
    object@nObs <- object@nObs + n

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataOrdinal ----

#' Updating `DataOrdinal` Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that updates existing [`DataOrdinal`] object with new data.
#'
#' @param object (`DataOrdinal`)\cr object you want to update.
#' @param x (`number`)\cr the dose level (one level only!).
#' @param y (`integer`)\cr the vector of toxicity grades (0, 1, 2, ...) for all
#' patients in this cohort. You can also supply `numeric` vectors, but these
#' will then be converted to `integer` internally.
#' @param ID (`integer`)\cr the patient IDs.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param new_cohort (`flag`)\cr if `TRUE` (default) the new data are assigned
#'   to a new cohort.
#' @param check (`flag`)\cr whether the validation of the updated object should
#'   be conducted. See Details below.
#' @param ... not used.
#'
#' @return The new, updated [`DataOrdinal`] object.
#'
#' @details The current implementation of this `update` method allows for
#'   updating the `DataOrdinal` class object by adding a single dose level `x` only.
#'   However, there might be some use cases where the new cohort to be added
#'   contains a placebo and active dose. Hence, such update would need to be
#'   performed iteratively by calling the `update` method twice. For example,
#'   in the first call a user can add a placebo, and then in the second call,
#'   an active dose. Since having a cohort with placebo only is not allowed,
#'   the `update` method would normally throw the error when attempting to add
#'   a placebo in the first call. To allow for such updates, the `check`
#'   parameter should be then set to `FALSE` for that first call.
#'
#' @aliases update-DataOrdinal
#' @export
#' @example examples/DataOrdinal-method-update.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataOrdinal"),
  definition = function(
    object,
    x,
    y,
    ID = length(object@ID) + seq_along(y),
    new_cohort = TRUE,
    check = TRUE,
    ...
  ) {
    assert_numeric(x, min.len = 0, max.len = 1)
    assert_integerish(
      y,
      lower = 0,
      upper = length(object@yCategories) - 1,
      any.missing = FALSE
    )
    assert_integerish(ID, unique = TRUE, any.missing = FALSE, len = length(y))
    assert_disjunct(object@ID, ID)
    assert_flag(new_cohort)
    assert_flag(check)

    # How many additional patients, ie. the length of the update.
    n <- length(y)

    # Which grid level is the dose?
    gridLevel <- match_within_tolerance(x, object@doseGrid)
    object@xLevel <- c(object@xLevel, rep(gridLevel, n))

    # Add dose.
    object@x <- c(object@x, rep(as.numeric(x), n))

    # Add DLT data.
    object@y <- c(object@y, as.integer(y))

    # Add ID.
    object@ID <- c(object@ID, as.integer(ID))

    # Add cohort number.
    new_cohort_id <- if (object@nObs == 0) {
      1L
    } else {
      tail(object@cohort, 1L) + ifelse(new_cohort, 1L, 0L)
    }
    object@cohort <- c(object@cohort, rep(new_cohort_id, n))

    # Increment sample size.
    object@nObs <- object@nObs + n

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataParts ----

#' Updating `DataParts` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`DataParts`] object with new data.
#'
#' @param object (`DataParts`)\cr object you want to update.
#' @inheritParams update,Data-method
#' @param ... further arguments passed to `Data` update method [`update-Data`].
#' @param check (`flag`)\cr whether the validation of the updated object
#'   should be conducted. See help for [`update-Data`] for more details
#'   on the use case of this parameter.
#'
#' @return The new, updated [`DataParts`] object.
#'
#' @aliases update-DataParts
#' @export
#' @example examples/Data-method-update-DataParts.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataParts"),
  definition = function(object, x, y, ..., check = TRUE) {
    assert_numeric(y)
    assert_flag(check)

    # Update slots corresponding to `Data` class.
    object <- callNextMethod(object = object, x = x, y = y, ..., check = FALSE)

    # Update the part information.

    object@part <- c(object@part, rep(object@nextPart, length(y)))

    # Decide which part the next cohort will belong to:
    # only if the `nextPart` was 1, it can potentially be required
    # to change it to 2 (once it is 2, it stays).
    if (object@nextPart == 1L) {
      # If there was a DLT in one of the cohorts,
      # or if the current dose was the highest from part 1.
      if (any(object@y == 1L) || x == max(object@part1Ladder)) {
        # Then this closes part 1 and the next cohort will be from part 2.
        object@nextPart <- 2L
      }
    }

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataDual ----

#' Updating `DataDual` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`DataDual`] object with new data.
#'
#' @param object (`DataDual`)\cr object you want to update.
#' @param w (`numeric`)\cr the continuous vector of biomarker values
#'   for all the patients in this update.
#' @param ... further arguments passed to `Data` update method [`update-Data`].
#' @param check (`flag`)\cr whether the validation of the updated object
#'   should be conducted. See help for [`update-Data`] for more details
#'   on the use case of this parameter.
#'
#' @return The new, updated [`DataDual`] object.
#'
#' @aliases update-DataDual
#' @export
#' @example examples/Data-method-update-DataDual.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataDual"),
  definition = function(object, w, ..., check = TRUE) {
    assert_numeric(w)
    assert_flag(check)

    # Update slots corresponding to `Data` class.
    object <- callNextMethod(object = object, ..., check = FALSE)

    # Update the biomarker information.
    object@w <- c(object@w, w)

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataDA ----

#' Updating `DataDA` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`DataDA`] object with new data.
#'
#' @note This function is capable of not only adding new patients but also
#'   updates existing ones with respect to `y`, `t0`, `u` slots.
#'
#' @param object (`DataDA`)\cr object you want to update.
#' @param u (`numeric`)\cr the new DLT free survival times for all patients,
#'   i.e. for existing patients in the `object` as well as for new patients.
#' @param t0 (`numeric`)\cr the time that each patient starts DLT observation
#'   window. This parameter covers all patients, i.e. existing patients in the
#'   `object` as well as for new patients.
#' @param trialtime (`number`)\cr current time in the trial, i.e. a followup
#'   time.
#' @param y (`numeric`)\cr the new DLTs for all patients, i.e. for existing
#'   patients in the `object` as well as for new patients.
#' @param ... further arguments passed to `Data` update method [`update-Data`].
#'   These are used when there are new patients to be added to the cohort.
#' @param check (`flag`)\cr whether the validation of the updated object
#'   should be conducted. See help for [`update-Data`] for more details
#'   on the use case of this parameter.
#'
#' @return The new, updated [`DataDA`] object.
#'
#' @aliases update-DataDA
#' @export
#' @example examples/Data-method-update-DataDA.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataDA"),
  definition = function(object, u, t0, trialtime, y, ..., check = TRUE) {
    assert_flag(check)
    assert_numeric(y, lower = 0, upper = 1)
    assert_true(length(y) == 0 || length(y) >= object@nObs)
    assert_numeric(u, lower = 0, len = length(y))
    assert_numeric(t0, lower = 0, len = length(y))
    assert_integerish(y * (trialtime >= t0 + u))
    if (length(y) > 0) {
      assert_number(trialtime, lower = max(c(object@t0, t0)))
    }

    # How many additional patients.
    n <- max(length(y) - object@nObs, 0L)

    # Update slots corresponding to `Data` class.
    object <- callNextMethod(
      object = object,
      y = y[object@nObs + seq_len(n)], # Empty vector when n = 0.
      ...,
      check = FALSE
    )

    # DLT will be observed once the followup time >= the time to DLT
    # and y = 1 at the same time.
    object@y <- as.integer(y * (trialtime >= t0 + u))

    # Update DLT free survival time.
    object@u <- apply(rbind(u, trialtime - t0), 2, min)

    # Update t0.
    object@t0 <- t0

    if (check) {
      validObject(object)
    }

    object
  }
)

# getEff ----

## generic ----

#' Extracting Efficacy Responses for Subjects Categorized by the DLT
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that extracts efficacy responses for subjects and categorizes it
#' with respect to DLT, i.e. DLT or no DLT. The efficacy responses
#' are reported together with their corresponding dose levels.
#'
#' @param object (`DataDual`)\cr object from which the responses and dose levels
#'   are extracted.
#' @param ... further arguments passed to class-specific methods.
#' @return `list` with efficacy responses categorized by the DLT value.
#' @export
#'
setGeneric(
  name = "getEff",
  def = function(object, ...) {
    standardGeneric("getEff")
  },
  valueClass = "list"
)

## DataDual ----

#' @rdname getEff
#'
#' @param no_dlt (`flag`)\cr should only no DLT responses be returned? Otherwise,
#'   all responses are returned.
#'
#' @aliases getEff-DataDual
#' @example examples/Data-method-getEff.R
#'
setMethod(
  f = "getEff",
  signature = signature(object = "DataDual"),
  definition = function(object, no_dlt = FALSE) {
    assert_flag(no_dlt)

    is_dlt <- object@y == 1L
    is_no_dlt <- !is_dlt

    eff <- if (any(is_no_dlt)) {
      list(x_no_dlt = object@x[is_no_dlt], w_no_dlt = object@w[is_no_dlt])
    } else {
      list(x_no_dlt = NULL, w_no_dlt = NULL)
    }

    if (!no_dlt) {
      eff_dlt <- if (any(is_dlt)) {
        list(x_dlt = object@x[is_dlt], w_dlt = object@w[is_dlt])
      } else {
        list(x_dlt = NULL, w_dlt = NULL)
      }
      eff <- c(eff, eff_dlt)
    }
    eff
  }
)

# ngrid ----

## generic ----

#' Number of Doses in Grid
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that gets the number of doses in grid. User can choose whether
#' the placebo dose (if any) should be counted or not.
#'
#' @param object (`Data`)\cr object with dose grid.
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#' @param ... further arguments passed to class-specific methods.
#' @return `integer` the number of doses in grid.
#' @export
#'
setGeneric(
  name = "ngrid",
  def = function(object, ignore_placebo = TRUE, ...) {
    assert_flag(ignore_placebo)
    standardGeneric("ngrid")
  },
  valueClass = "integer"
)

## Data ----

#' @rdname ngrid
#'
#' @aliases ngrid-Data
#' @example examples/Data-method-ngrid.R
#'
setMethod(
  f = "ngrid",
  signature = signature(object = "Data"),
  definition = function(object, ignore_placebo, ...) {
    if (ignore_placebo && object@placebo) {
      max(object@nGrid - 1L, 0L)
    } else {
      object@nGrid
    }
  }
)

# dose_grid_range ----

## generic ----

#' Getting the Dose Grid Range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that returns a vector of length two with the minimum and maximum
#' dose in a grid. It returns `c(-Inf, Inf)` if the range cannot be determined,
#' which happens when the dose grid is empty. User can choose whether the
#' placebo dose (if any) should be counted or not.
#'
#' @param object (`Data`)\cr object with dose grid.
#' @param ... further arguments passed to class-specific methods.
#' @return A `numeric` vector containing the minimum and maximum of all the
#'   doses in a grid or `c(-Inf, Inf)`.
#'
#' @export
#'
setGeneric(
  name = "dose_grid_range",
  def = function(object, ...) {
    standardGeneric("dose_grid_range")
  },
  valueClass = "numeric"
)

## Data ----

#' @rdname dose_grid_range
#'
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#'
#' @aliases dose_grid_range-Data
#' @example examples/Data-method-dose_grid_range.R
#'
setMethod(
  f = "dose_grid_range",
  signature = signature(object = "Data"),
  definition = function(object, ignore_placebo = TRUE) {
    h_obtain_dose_grid_range(object, ignore_placebo)
  }
)


## DataOrdinal ----

#' @include Data-methods.R
#' @rdname dose_grid_range
#' @description `r lifecycle::badge("experimental")`
#'
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#'
#' @aliases dose_grid_range-Data
#' @example examples/DataOrdinal-method-dose_grid_range.R
#'
setMethod(
  f = "dose_grid_range",
  signature = signature(object = "DataOrdinal"),
  definition = function(object, ignore_placebo = TRUE) {
    h_obtain_dose_grid_range(object, ignore_placebo)
  }
)

# tidy ----

## GeneralData ----

#' Tidy Method for the [`GeneralData`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`GeneralData`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-GeneralData
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "GeneralData"),
  definition = function(x, ...) {
    d <- tibble::tibble(
      ID = x@ID,
      Cohort = x@cohort,
      Dose = x@x,
      XLevel = x@xLevel,
      Tox = as.logical(x@y),
      Placebo = x@placebo,
      NObs = x@nObs,
      NGrid = x@nGrid,
      DoseGrid = list(x@doseGrid)
    ) %>%
      h_tidy_class(x)
  }
)

## DataGrouped ----

#' Tidy Method for the [`DataGrouped`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataGrouped`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataGrouped
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataGrouped"),
  definition = function(x, ...) {
    d <- callNextMethod()
    d %>%
      tibble::add_column(Group = x@group) %>%
      h_tidy_class(x)
  }
)

## DataDA ----

#' Tidy Method for the [`DataDA`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataDA`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataDA
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataDA"),
  definition = function(x, ...) {
    d <- callNextMethod()
    d %>%
      tibble::add_column(U = x@u) %>%
      tibble::add_column(T0 = x@t0) %>%
      tibble::add_column(TMax = x@Tmax) %>%
      h_tidy_class(x)
  }
)

## DataDA ----

#' Tidy Method for the [`DataDual`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataDual`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataDual
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataDual"),
  definition = function(x, ...) {
    d <- callNextMethod()
    d %>%
      tibble::add_column(W = x@w) %>%
      h_tidy_class(x)
  }
)

## DataParts ----

#' Tidy Method for the [`DataParts`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataParts`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataParts
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataParts"),
  definition = function(x, ...) {
    d <- callNextMethod()
    d %>%
      tibble::add_column(Part = x@part) %>%
      tibble::add_column(NextPart = x@nextPart) %>%
      tibble::add_column(Part1Ladder = list(x@part1Ladder)) %>%
      h_tidy_class(x)
  }
)

## DataMixture ----

#' Tidy Method for the [`DataMixture`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataMixture`] object.
#' @section Usage Notes:
#' The prior observations are indicated by a `Cohort` value of `0` in the returned
#' `tibble`.
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataMixture
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataMixture"),
  definition = function(x, ...) {
    observed <- callNextMethod()
    tibble::tibble(
      Cohort = 0,
      Dose = x@xshare,
      Tox = as.logical(x@yshare),
      ID = sort(seq_along(x@xshare)),
      Placebo = x@placebo,
      NObs = x@nObs,
      NGrid = x@nGrid,
      DoseGrid = list(x@doseGrid),
      XLevel = which(x@doseGrid %in% x@xshare)
    ) %>%
      dplyr::bind_rows(observed) %>%
      h_tidy_class(x)
  }
)


## DataOrdinal ----

#' Tidy Method for the [`DataMixture`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataOrdinal`] object.
#' @section Usage Notes:
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataOrdinal
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataOrdinal"),
  definition = function(x, ...) {
    y <- tibble::tibble(
      ID = x@ID,
      Cohort = x@cohort,
      Dose = x@x,
      Tox = x@y,
      Placebo = x@placebo,
      NObs = x@nObs,
      NGrid = x@nGrid,
      DoseGrid = list(x@doseGrid),
      XLevel = x@xLevel
    ) %>%
      tidyr::pivot_wider(
        names_from = "Tox",
        values_from = "Tox",
        names_prefix = "Cat",
        values_fill = 0
      )
    if (nrow(y) > 0) {
      y <- y %>%
        dplyr::mutate(
          dplyr::across(tidyselect::matches("Cat\\d+"), \(x) x > 0)
        ) %>%
        dplyr::rowwise() %>%
        dplyr::mutate(
          AnyTox = any(dplyr::across(
            c(tidyselect::starts_with("Cat"), -tidyselect::all_of("Cat0")),
            any
          )),
          # Direct assignment fails on GitHub
          Cat0 = !.data$AnyTox
        ) %>%
        dplyr::select(-tidyselect::all_of("AnyTox")) %>%
        dplyr::ungroup()
    }
    y <- y %>% h_tidy_class(x)
    y
  }
)

#' Internal Helper Functions for Validation of Model Parameters Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' These functions are only used internally to validate the format of an object
#' with model parameters or inherited classes and therefore not exported.
#'
#' @name v_model_params
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_model_params a helper function that validates multivariate normal
#'   parameters.
#' @param object (`ModelParamsNormal`)\cr multivariate normal parameters object
#'   to validate.
v_model_params_normal <- function(object) {
  v <- Validate()

  v$check(
    test_numeric(x = object@mean, min.len = 2L, any.missing = FALSE),
    "mean must have length of at least 2 and no missing values are allowed"
  )
  is_cov_valid <- h_is_positive_definite(object@cov, length(object@mean))
  v$check(
    is_cov_valid,
    "cov must be positive-definite matrix without any missing values"
  )
  is_prec_valid <- h_is_positive_definite(object@prec, length(object@mean))
  v$check(
    is_prec_valid,
    "prec must be positive-definite matrix without any missing values"
  )
  if (is_cov_valid && is_prec_valid) {
    v$check(
      all.equal(
        object@cov %*% object@prec,
        diag(1, length(object@mean)),
        check.attributes = FALSE
      ) ==
        TRUE,
      "prec must be inverse of cov"
    )
  }
  v$result()
}

# for nextBest methods ----

## some specific helpers ----

#' Calculating the Information Theoretic Distance
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which provides the value of the
#' divergence as given by equation in (7) in the reference at
#' https://doi.org/10.1002/sim.8450.
#'
#' @param prob (`numeric`)\cr vector or matrix with probabilities of a DLT occurring.
#' @param target (`number `)\cr single target probability of a DLT.
#' @param asymmetry (`number`)\cr describes the rate of penalization
#'   for overly toxic does, range 0 to 2.
#'
#' @export
#' @examples
#' h_info_theory_dist(c(0.5, 0.2), 0.4, 1.2)
h_info_theory_dist <- function(prob, target, asymmetry) {
  assert_probabilities(prob)
  assert_true(test_vector(prob) || test_matrix(prob))
  assert_number(target, finite = TRUE)
  assert_number(asymmetry, lower = 0, upper = 2)

  ((prob - target)^2) / (((prob^asymmetry) * (1 - prob)^(2 - asymmetry)))
}

#' Credibility Intervals for Max Gain and Target Doses at `nextBest-NextBestMaxGain` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function for [`nextBest-NextBestMaxGain()`] method. It computes a
#' 95% credibility intervals for given target dose and max gain dose.
#' It also returns a ratio of upper and lower bounds of the interval.
#'
#' @param dose_target (`number`)\cr target dose estimate.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param prob_target (`proportion`)\cr target DLT probability.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level in the dose grid used
#'   is considered as placebo. This is needed to adjust the max gain dose using
#'   efficacy constant value. If the `placebo` was used, then the `model_eff@const`
#'   is added to `dose_mg`.
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog`)\cr the efficacy model.
#'
#' @references
#'   Yeung, W.Y., Whitehead, J., Reigner, B., Beyer, U., Diack, Ch., Jaki, T. (2015),
#'   Bayesian adaptive dose-escalation procedures for binary and continuous responses utilizing a gain function,
#'   *Pharmaceutical Statistics*,
#'   \doi{10.1002/pst.1706} \cr
#'
#' @export
#'
h_next_best_mg_ci <- function(
  dose_target,
  dose_mg,
  prob_target,
  placebo,
  model,
  model_eff
) {
  assert_number(dose_target, na.ok = TRUE)
  assert_number(dose_mg, na.ok = TRUE)
  assert_probability(prob_target)
  assert_flag(placebo)
  assert_class(model, "ModelTox")
  assert_class(model_eff, "Effloglog")

  # Find the variance of the log of target dose.
  mat <- matrix(
    c(
      -1 / (model@phi2),
      -(log(prob_target / (1 - prob_target)) - model@phi1) / (model@phi2)^2
    ),
    nrow = 1
  )
  var_dose_target <- as.vector(mat %*% model@Pcov %*% t(mat))

  # 95% credibility interval for target dose.
  ci_dose_target <- exp(
    log(dose_target) + c(-1, 1) * 1.96 * sqrt(var_dose_target)
  )
  cir_dose_target <- ci_dose_target[2] / ci_dose_target[1]

  # Find the variance of the log of dose_mg.
  # First, find the covariance matrix of all the parameters, phi1, phi2, theta1 and theta2
  # given that phi1 and phi2 are independent of theta1 and theta2.
  log_dose_mg <- log(dose_mg + ifelse(placebo, model_eff@const, 0))

  # Find a delta_g matrix for a variance according to Yeung et. al (2015).
  mean_eff_mg <- model_eff@theta1 + model_eff@theta2 * log(log_dose_mg)
  denom <- model@phi2 * mean_eff_mg * (1 + model@phi2 * log_dose_mg)
  dgphi1 <- -(mean_eff_mg * log_dose_mg * model@phi2 - model_eff@theta2) / denom
  dgphi2 <- -(log_dose_mg *
    (mean_eff_mg * (1 + log_dose_mg * model@phi2) - model_eff@theta2)) /
    denom
  dgtheta1 <- -(log_dose_mg * model@phi2) / denom
  dgtheta2_num <- -(exp(model@phi1 + model@phi2 * log_dose_mg) *
    (model@phi2 * log_dose_mg * log(log_dose_mg) - 1) -
    1)
  dgtheta2 <- dgtheta2_num / denom
  delta_g <- matrix(c(dgphi1, dgphi2, dgtheta1, dgtheta2), 4, 1)

  zero_matrix <- matrix(0, 2, 2)
  cov_beta <- cbind(
    rbind(model@Pcov, zero_matrix),
    rbind(zero_matrix, model_eff@Pcov)
  )
  var_log_dose_mg <- as.vector(t(delta_g) %*% cov_beta %*% delta_g)

  # 95% credibility interval for max gain dose.
  ci_mg <- exp(log_dose_mg + c(-1, 1) * 1.96 * sqrt(var_log_dose_mg))
  ci_ratio_mg <- ci_mg[2] / ci_mg[1]

  list(
    ci_dose_target = ci_dose_target,
    ci_ratio_dose_target = cir_dose_target,
    ci_dose_mg = ci_mg,
    ci_ratio_dose_mg = ci_ratio_mg
  )
}

## next best at grid ----

#' Get Closest Grid Doses for a Given Target Doses for `nextBest-NextBestMaxGain` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function that for a given target doses finds the dose in grid that is
#' closest and below the target. There are four different targets in the context
#' of [`nextBest-NextBestMaxGain()`] method: \eqn{min(`dose_mg`, `dose_target_drt`)},
#' `dose_mg`, `dose_target_drt` or `dose_target_eot`.
#'
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param dose_grid (`numeric`)\cr all possible doses.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level in the `dose_grid`
#'   is considered as placebo.
#'
#' @export
#'
h_next_best_mg_doses_at_grid <- function(
  dose_target_drt,
  dose_target_eot,
  dose_mg,
  dose_grid,
  doselimit,
  placebo
) {
  assert_number(dose_target_drt, na.ok = TRUE)
  assert_number(dose_target_eot, na.ok = TRUE)
  assert_number(dose_mg, na.ok = TRUE)

  doses_eligible <- h_next_best_eligible_doses(dose_grid, doselimit, placebo)

  # h_find_interval assumes that elements in doses_eligible are strictly increasing.
  next_dose_lev <- h_find_interval(
    min(dose_mg, dose_target_drt),
    doses_eligible
  )
  next_dose <- doses_eligible[next_dose_lev]

  next_dose_mg_lev <- h_find_interval(dose_mg, doses_eligible)
  next_dose_mg <- doses_eligible[next_dose_mg_lev]

  next_dose_lev_drt <- h_find_interval(dose_target_drt, doses_eligible)
  next_dose_drt <- doses_eligible[next_dose_lev_drt]

  next_dose_lev_eot <- h_find_interval(dose_target_eot, doses_eligible)
  next_dose_eot <- doses_eligible[next_dose_lev_eot]

  next_dose_list <- list(
    next_dose = next_dose,
    next_dose_drt = next_dose_drt,
    next_dose_eot = next_dose_eot,
    next_dose_mg = next_dose_mg
  )
}

## eligible doses ----

#' Get Eligible Doses from the Dose Grid.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function that gets the eligible doses from the dose grid.
#' The eligible doses are the doses which do not exceed a given
#' `doselimit`. For placebo design, if safety allows (i.e. if there is at least
#' one non-placebo dose which does not exceed the dose limit), the placebo dose
#' is then excluded from the eligible doses.
#'
#' @param dose_grid (`numeric`)\cr all possible doses.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level in the `dose_grid`
#'   is considered as placebo.
#' @param levels (`flag`)\cr if `TRUE` the levels of eligible doses are returned,
#'   otherwise, the doses (default).
#'
#' @return A numeric vector with eligible doses or eligible dose levels if `levels`
#'   flag is `TRUE`.
#'
#' @export
#' @examples
#' dose_grid <- c(0.001, seq(25, 200, 25))
#' h_next_best_eligible_doses(dose_grid, 79, TRUE)
#' h_next_best_eligible_doses(dose_grid, 24, TRUE)
h_next_best_eligible_doses <- function(
  dose_grid,
  doselimit,
  placebo,
  levels = FALSE
) {
  assert_numeric(
    dose_grid,
    finite = TRUE,
    any.missing = FALSE,
    min.len = 1L,
    sorted = TRUE
  )
  assert_number(doselimit)
  assert_flag(placebo)
  assert_flag(levels)

  is_dose_eligible <- dose_grid <= doselimit
  if (placebo && sum(is_dose_eligible) > 1L) {
    is_dose_eligible[1] <- FALSE
  }

  if (levels) {
    is_dose_eligible
  } else {
    dose_grid[is_dose_eligible]
  }
}

## plot ----

#' Building the Plot for `nextBest-NextBestNCRMLoss` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestNCRMLoss()`]
#' method.
#'
#' @param prob_mat (`numeric`)\cr matrix with probabilities of a grid doses
#'   to be in a given interval. If `is_unacceptable_specified` is `TRUE`, there
#'   must be 4 intervals (columns) in `prob_mat`: `underdosing`, `target`,
#'   `excessive`, `unacceptable`. Otherwise, there must be 3 intervals (columns):
#'   `underdosing`, `target`, `overdose`. Number of rows must be equal to number
#'   of doses in a grid.
#' @param posterior_loss (`numeric`)\cr posterior losses.
#' @param max_overdose_prob (`number`)\cr maximum overdose posterior
#'   probability that is allowed.
#' @param dose_grid (`numeric`)\cr dose grid.
#' @param max_eligible_dose_level (`number`)\cr maximum eligible dose level in
#'   the `dose_grid`.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param next_dose (`number`)\cr next best dose.
#' @param is_unacceptable_specified (`flag`)\cr is unacceptable interval specified?
#'
#' @export
h_next_best_ncrm_loss_plot <- function(
  prob_mat,
  posterior_loss,
  max_overdose_prob,
  dose_grid,
  max_eligible_dose_level,
  doselimit,
  next_dose,
  is_unacceptable_specified
) {
  assert_numeric(dose_grid, finite = TRUE, any.missing = FALSE, sorted = TRUE)
  n_grid <- length(dose_grid)
  assert_flag(is_unacceptable_specified)
  assert_probabilities(prob_mat)
  assert_matrix(
    prob_mat,
    min.cols = 3,
    max.cols = 4,
    nrows = n_grid,
    col.names = "named"
  )
  if (!is_unacceptable_specified) {
    assert_names(
      colnames(prob_mat),
      permutation.of = c("underdosing", "target", "overdose")
    )
  } else {
    assert_names(
      colnames(prob_mat),
      permutation.of = c("underdosing", "target", "excessive", "unacceptable")
    )
  }
  assert_numeric(
    posterior_loss,
    finite = TRUE,
    any.missing = FALSE,
    len = n_grid
  )
  assert_probability(max_overdose_prob)
  assert_number(max_eligible_dose_level, lower = 0, upper = n_grid)
  assert_number(doselimit)
  assert_number(next_dose, na.ok = TRUE)

  # Build plots, first for the target probability.
  p1 <- ggplot() +
    geom_bar(
      data = data.frame(Dose = dose_grid, y = prob_mat[, "target"] * 100),
      aes(x = .data$Dose, y = .data$y),
      stat = "identity",
      position = "identity",
      width = min(diff(dose_grid)) / 2,
      colour = "darkgreen",
      fill = "darkgreen"
    ) +
    ylim(c(0, 100)) +
    ylab(paste("Target probability [%]"))

  if (is.finite(doselimit)) {
    p1 <- p1 +
      geom_vline(xintercept = doselimit, lwd = 1.1, lty = 2, colour = "black")
  }

  if (max_eligible_dose_level > 0) {
    p1 <- p1 +
      geom_vline(
        xintercept = dose_grid[max_eligible_dose_level],
        lwd = 1.1,
        lty = 2,
        colour = "red"
      )
  }

  p_loss <- ggplot() +
    # For the loss function.
    geom_bar(
      data = data.frame(Dose = dose_grid, y = posterior_loss),
      aes(x = .data$Dose, y = .data$y),
      stat = "identity",
      position = "identity",
      width = min(diff(dose_grid)) / 2,
      colour = "darkgreen",
      fill = "darkgreen"
    ) +
    geom_point(
      aes(x = next_dose, y = max(posterior_loss) + 0.2),
      size = 3,
      pch = 25,
      col = "red",
      bg = "red"
    ) +
    ylab(paste("Loss function"))

  if (!is_unacceptable_specified) {
    # Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = dose_grid, y = prob_mat[, "overdose"] * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(dose_grid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      geom_hline(
        yintercept = max_overdose_prob * 100,
        lwd = 1.1,
        lty = 2,
        colour = "black"
      ) +
      ylim(c(0, 100)) +
      ylab("Overdose probability [%]")

    # Combine it all together.
    plots_single <- list(plot1 = p1, plot2 = p2, plot_loss = p_loss)
    plot_joint <- gridExtra::arrangeGrob(p1, p2, p_loss, nrow = 3)
  } else {
    # Plot in case of 4 toxicity intervals. Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = dose_grid, y = prob_mat[, "excessive"] * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(dose_grid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      ylim(c(0, 100)) +
      ylab("Excessive probability [%]")

    p3 <- ggplot() +
      geom_bar(
        data = data.frame(
          Dose = dose_grid,
          y = prob_mat[, "unacceptable"] * 100
        ),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(dose_grid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      ylim(c(0, 100)) +
      ylab("Unacceptable probability [%]")

    # Combine it all together.
    plots_single <- list(plot1 = p1, plot2 = p2, plot3 = p3, plot_loss = p_loss)
    plot_joint <- gridExtra::arrangeGrob(p1, p2, p3, p_loss, nrow = 4)
  }

  list(plots_single = plots_single, plot_joint = plot_joint)
}

#' Building the Plot for `nextBest-NextBestTDsamples` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestTDsamples()`]
#' method.
#'
#' @param dose_target_drt_samples (`numeric`)\cr vector of in-trial samples.
#' @param dose_target_eot_samples (`numeric`)\cr vector of end-of-trial samples.
#' @param dose_target_drt (`number`)\cr target in-trial estimate.
#' @param dose_target_eot (`number`)\cr target end-of-trial estimate.
#' @param dose_grid_range (`numeric`)\cr range of dose grid.
#' @param nextBest (`NextBestTDsamples`)\cr the rule for the next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param next_dose (`number`)\cr next best dose.
#'
#' @export
#'
h_next_best_tdsamples_plot <- function(
  dose_target_drt_samples,
  dose_target_eot_samples,
  dose_target_drt,
  dose_target_eot,
  dose_grid_range,
  nextBest,
  doselimit,
  next_dose
) {
  assert_numeric(dose_target_drt_samples, any.missing = FALSE)
  assert_numeric(dose_target_eot_samples, any.missing = FALSE)
  assert_number(dose_target_drt)
  assert_number(dose_target_eot)
  assert_range(dose_grid_range, finite = TRUE, unique = FALSE)
  assert_class(nextBest, "NextBestTDsamples")
  assert_number(doselimit)
  assert_number(next_dose, na.ok = TRUE)

  lbl1 <- paste("TD", nextBest@prob_target_drt * 100, "Estimate")
  lbl2 <- paste("TD", nextBest@prob_target_eot * 100, "Estimate")
  labels <- data.frame(
    Type = c("during", "end", "Max", "Next"),
    Alpha = c(0.25, 0.25, 1, 1),
    x = c(
      dose_target_drt,
      dose_target_eot,
      min(doselimit, dose_grid_range[2]),
      next_dose
    )
  )
  p <- ggplot(
    data = rbind(
      data.frame(period = "during", TD = dose_target_drt_samples),
      data.frame(period = "end", TD = dose_target_eot_samples)
    ),
    aes(x = .data$TD, colour = .data$period),
  ) +
    geom_density(
      aes(fill = .data$period, colour = .data$period),
      alpha = 0.25,
      bounds = dose_grid_range,
      show.legend = FALSE
    ) +
    geom_vline(data = labels, aes(xintercept = x, colour = Type)) +
    ylab("Posterior density") +
    scale_colour_manual(
      name = NULL,
      values = c(
        "during" = "orange",
        "end" = "violet",
        "Max" = "red",
        "Next" = "blue"
      ),
      labels = c("during" = lbl1, "end" = lbl2, "Max" = "Max", "Next" = "Next")
    ) +
    scale_fill_manual(
      values = c("during" = "orange", "end" = "violet")
    )
}

#' Building the Plot for `nextBest-NextBestTD` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestTD()`] method.
#'
#' @param prob_target_drt (`proportion`)\cr target DLT probability during the trial.
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param prob_target_eot (`proportion`)\cr target DLT probability at the end of the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param data (`Data`)\cr the data object from which the dose grid will be fetched.
#' @param prob_dlt (`numeric`)\cr DLT probabilities for doses in grid.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param next_dose (`number`)\cr next best dose.
#'
#' @export
#'
h_next_best_td_plot <- function(
  prob_target_drt,
  dose_target_drt,
  prob_target_eot,
  dose_target_eot,
  data,
  prob_dlt,
  doselimit,
  next_dose
) {
  assert_probability(prob_target_drt)
  assert_number(dose_target_drt)
  assert_probability(prob_target_eot)
  assert_number(dose_target_eot)
  assert_class(data, "Data")
  assert_probabilities(prob_dlt, len = data@nGrid)
  assert_number(doselimit)
  assert_number(next_dose, na.ok = TRUE)

  dosegrid_range <- dose_grid_range(data)

  p <- ggplot(
    data = data.frame(x = data@doseGrid, y = prob_dlt),
    aes(x = .data$x, y = .data$y)
  ) +
    geom_line(colour = "red", linewidth = 1.5) +
    coord_cartesian(xlim = c(0, dosegrid_range[2])) +
    ylim(c(0, 1)) +
    xlab("Dose Levels") +
    ylab("Probability of DLT")
  if (
    h_in_range(dose_target_drt, range = dosegrid_range, bounds_closed = TRUE)
  ) {
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_drt, y = prob_target_drt),
        aes(x = .data$x, y = .data$y),
        colour = "orange",
        shape = 15,
        size = 8
      ) +
      annotate(
        geom = "text",
        label = paste("TD", prob_target_drt * 100, "Estimate"),
        x = dose_target_drt + 1,
        y = prob_target_drt - 0.2,
        size = 5,
        colour = "orange"
      )
  }

  if (
    h_in_range(dose_target_eot, range = dosegrid_range, bounds_closed = TRUE)
  ) {
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_eot, y = prob_target_eot),
        aes(x = .data$x, y = .data$y),
        colour = "violet",
        shape = 16,
        size = 8
      ) +
      annotate(
        geom = "text",
        label = paste("TD", prob_target_eot * 100, "Estimate"),
        x = dose_target_eot + 1,
        y = prob_target_eot - 0.1,
        size = 5,
        colour = "violet"
      )
  }

  maxdoselimit <- min(doselimit, dosegrid_range[2])

  p +
    geom_vline(xintercept = maxdoselimit, colour = "brown", lwd = 1.1) +
    geom_text(
      data = data.frame(x = maxdoselimit, y = 0),
      aes(x = .data$x, y = .data$y, label = "Max", hjust = +1, vjust = -30),
      angle = 90,
      vjust = 1.5,
      hjust = 0.5,
      colour = "brown",
    ) +
    geom_vline(xintercept = next_dose, colour = "purple", lwd = 1.1) +
    geom_text(
      data = data.frame(x = next_dose, y = 0),
      aes(x = .data$x, y = .data$y, label = "Next", hjust = 0, vjust = -30),
      angle = 90,
      vjust = -0.5,
      hjust = 0.5,
      colour = "purple"
    )
}

#' Building the Plot for `nextBest-NextBestMaxGain` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestMaxGain()`] method.
#'
#' @param prob_target_drt (`proportion`)\cr target DLT probability during the trial.
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param prob_target_eot (`proportion`)\cr target DLT probability at the end of the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param max_gain (`number`)\cr the maximum gain estimate.
#' @param next_dose (`number`)\cr next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param data (`DataDual`)\cr the data object from which the dose grid will be fetched.
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog`)\cr the efficacy model.
#'
#' @export
#'
h_next_best_mg_plot <- function(
  prob_target_drt,
  dose_target_drt,
  prob_target_eot,
  dose_target_eot,
  dose_mg,
  max_gain,
  next_dose,
  doselimit,
  data,
  model,
  model_eff
) {
  assert_probability(prob_target_drt)
  assert_number(dose_target_drt)
  assert_probability(prob_target_eot)
  assert_number(dose_target_eot)
  assert_number(dose_mg, na.ok = TRUE)
  assert_number(max_gain, na.ok = TRUE)
  assert_number(next_dose, na.ok = TRUE)
  assert_number(doselimit)
  assert_class(data, "Data")
  assert_class(model, "ModelTox")
  assert_class(model_eff, "Effloglog")

  dosegrid_range <- dose_grid_range(data)

  data_plot <- data.frame(
    dose = rep(data@doseGrid, 3),
    y = c(
      prob(dose = data@doseGrid, model = model),
      efficacy(dose = data@doseGrid, model = model_eff),
      gain(dose = data@doseGrid, model_dle = model, model_eff = model_eff)
    ),
    group = c(
      rep("p(DLE)", data@nGrid),
      rep("Expected Efficacy", data@nGrid),
      rep("Gain", data@nGrid)
    )
  )

  p <- ggplot(data = data_plot, aes(x = .data$dose, y = .data$y)) +
    geom_line(aes(group = group, color = group), linewidth = 1.5) +
    ggplot2::scale_colour_manual(
      name = "curves",
      values = c("blue", "green3", "red")
    ) +
    coord_cartesian(xlim = c(0, dosegrid_range[2])) +
    ylim(range(data_plot$y)) +
    xlab("Dose Level") +
    ylab("Values")

  if (
    h_in_range(dose_target_eot, range = dosegrid_range, bounds_closed = FALSE)
  ) {
    lab <- paste("TD", prob_target_eot * 100, "Estimate")
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_eot, y = prob_target_eot),
        aes(x = .data$x, y = .data$y),
        colour = "violet",
        shape = 16,
        size = 8
      ) +
      annotate(
        geom = "text",
        label = lab,
        x = dose_target_eot - 1,
        y = 0.2,
        size = 5,
        colour = "violet"
      )
  }

  if (h_in_range(dose_mg, range = dosegrid_range, bounds_closed = FALSE)) {
    p <- p +
      geom_point(
        data = data.frame(x = dose_mg, y = max_gain),
        aes(x = .data$x, y = .data$y),
        colour = "green3",
        shape = 17,
        size = 8
      ) +
      annotate(
        "text",
        label = "Max Gain Estimate",
        x = dose_mg,
        y = max_gain - 0.1,
        size = 5,
        colour = "green3"
      )
  }

  if (
    h_in_range(dose_target_drt, range = dosegrid_range, bounds_closed = FALSE)
  ) {
    lab <- paste("TD", prob_target_drt * 100, "Estimate")
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_drt, y = prob_target_drt),
        aes(x = .data$x, y = .data$y),
        colour = "orange",
        shape = 15,
        size = 8
      ) +
      annotate(
        geom = "text",
        label = lab,
        x = dose_target_drt + 25,
        y = prob_target_drt + 0.01,
        size = 5,
        colour = "orange"
      )
  }

  maxdoselimit <- min(doselimit, dosegrid_range[2])

  p +
    geom_vline(xintercept = maxdoselimit, colour = "brown", lwd = 1.1) +
    annotate(
      geom = "text",
      label = "Max",
      x = maxdoselimit - 2,
      y = max(data_plot$y),
      size = 5,
      angle = 90,
      vjust = -0.5,
      hjust = 0.5,
      colour = "brown"
    ) +
    geom_vline(xintercept = next_dose, colour = "purple", lwd = 1.1) +
    annotate(
      geom = "text",
      label = "Next",
      x = next_dose + 1,
      y = max(data_plot$y) - 0.05,
      size = 5,
      angle = 90,
      vjust = 1.5,
      hjust = 0.5,
      color = "purple"
    )
}

#' Building the Plot for `nextBest-NextBestMaxGainSamples` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestMaxGainSamples()`] method.
#'
#' @param prob_target_drt (`proportion`)\cr target DLT probability during the trial.
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param prob_target_eot (`proportion`)\cr target DLT probability at the end of the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param dose_mg_samples (`numeric`)\cr for every sample, the dose (from the dose grid)
#'   that gives the maximum gain value.
#' @param next_dose (`number`)\cr next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param dose_grid_range (`numeric`)\cr dose grid range.
#'
#' @export
#'
h_next_best_mgsamples_plot <- function(
  prob_target_drt,
  dose_target_drt,
  prob_target_eot,
  dose_target_eot,
  dose_mg,
  dose_mg_samples,
  next_dose,
  doselimit,
  dose_grid_range
) {
  assert_range(dose_grid_range, finite = TRUE, unique = FALSE)
  assert_probability(prob_target_drt)
  assert_number(dose_target_drt)
  assert_probability(prob_target_eot)
  assert_number(dose_target_eot)
  assert_number(dose_mg, na.ok = TRUE)
  assert_numeric(
    dose_mg_samples,
    lower = dose_grid_range[1],
    upper = dose_grid_range[2],
    finite = TRUE,
    any.missing = FALSE
  )
  assert_number(next_dose, na.ok = TRUE)
  assert_number(doselimit)

  p <- ggplot() +
    geom_histogram(
      data = data.frame(Gstar = dose_mg_samples),
      aes(x = .data$Gstar),
      fill = "darkgreen",
      colour = "green3",
      binwidth = 25
    ) +
    coord_cartesian(xlim = c(0, dose_grid_range[2])) +
    ylab("Posterior density")

  if (
    h_in_range(dose_target_drt, range = dose_grid_range, bounds_closed = FALSE)
  ) {
    lab <- paste("TD", prob_target_drt * 100, "Estimate")
    p <- p +
      geom_vline(xintercept = dose_target_drt, colour = "orange", lwd = 1.1) +
      annotate(
        geom = "text",
        label = lab,
        x = dose_target_drt,
        y = 0,
        hjust = -0.1,
        vjust = -20,
        size = 5,
        colour = "orange"
      )
  }

  if (
    h_in_range(dose_target_eot, range = dose_grid_range, bounds_closed = FALSE)
  ) {
    lab <- paste("TD", prob_target_eot * 100, "Estimate")
    p <- p +
      geom_vline(xintercept = dose_target_eot, colour = "violet", lwd = 1.1) +
      annotate(
        geom = "text",
        label = lab,
        x = dose_target_eot,
        y = 0,
        hjust = -0.1,
        vjust = -25,
        size = 5,
        colour = "violet"
      )
  }

  if (h_in_range(dose_mg, range = dose_grid_range, bounds_closed = FALSE)) {
    lab <- "Gstar Estimate"
    p <- p +
      geom_vline(xintercept = dose_mg, colour = "green", lwd = 1.1) +
      annotate(
        geom = "text",
        label = lab,
        x = dose_mg,
        y = 0,
        hjust = -0.1,
        vjust = -25,
        size = 5,
        colour = "green"
      )
  }

  maxdoselimit <- min(doselimit, dose_grid_range[2])

  p +
    geom_vline(xintercept = maxdoselimit, colour = "red", lwd = 1.1) +
    annotate(
      geom = "text",
      label = "Max",
      x = maxdoselimit,
      y = 0,
      hjust = +1,
      vjust = -35,
      colour = "red"
    ) +
    geom_vline(xintercept = next_dose, colour = "blue", lwd = 1.1) +
    annotate(
      geom = "text",
      label = "Next",
      x = next_dose,
      y = 0,
      hjust = 0.1,
      vjust = -30,
      colour = "blue"
    )
}

# NextBest ----

#' Internal Helper Functions for Validation of [`NextBest`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`NextBest`] or inherited classes and therefore not exported.
#'
#' @name v_next_best
#' @param object (`NextBest`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_next_best validates that the [`NextBestMTD`] object
#'   contains valid `target` probability and `derive` function.
v_next_best_mtd <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_function(object@derive, nargs = 1),
    "derive must have a single argument"
  )
  v$check(
    test_number(object@derive(1:5)),
    "derive must accept numerical vector as an argument and return a number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestNCRM`] object
#'   contains valid `target` probability, `overdose` and `max_overdose_prob`
#'   probability ranges.
v_next_best_ncrm <- function(object) {
  v <- Validate()
  v$check(
    test_probability_range(object@target),
    "target has to be a probability range"
  )
  v$check(
    test_probability_range(object@overdose),
    "overdose has to be a probability range"
  )
  v$check(
    test_probability(object@max_overdose_prob, bounds_closed = FALSE),
    "max_overdose_prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestNCRMLoss`] object
#'   contains valid objects.
v_next_best_ncrm_loss <- function(object) {
  v <- Validate()
  v$check(
    test_probability_range(object@target, bounds_closed = FALSE),
    "target has to be a probability range excluding 0 and 1"
  )

  is_overdose_ok <- test_probability_range(
    object@overdose,
    bounds_closed = TRUE
  )
  v$check(is_overdose_ok, "overdose has to be a probability range")

  is_unacceptable_ok <- test_probability_range(
    object@unacceptable,
    bounds_closed = TRUE
  )
  v$check(is_unacceptable_ok, "unacceptable has to be a probability range")

  if (is_overdose_ok && is_unacceptable_ok) {
    v$check(
      object@overdose[2] <= object@unacceptable[1],
      "lower bound of unacceptable has to be >= than upper bound of overdose"
    )
  }
  if (is_unacceptable_ok) {
    losses_len <- ifelse(all(object@unacceptable == c(1, 1)), 3L, 4L)
    v$check(
      test_numeric(
        object@losses,
        lower = 0,
        finite = TRUE,
        any.missing = FALSE,
        len = losses_len
      ),
      "losses must be a vector of non-negative numbers of length 3 if unacceptable is c(1, 1), otherwise 4"
    )
  }
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestDualEndpoint`] object
#'   contains valid probability objects.
v_next_best_dual_endpoint <- function(object) {
  v <- Validate()
  v$check(
    test_flag(object@target_relative),
    "target_relative must be a flag"
  )
  if (isTRUE(object@target_relative)) {
    v$check(
      test_probability_range(object@target),
      "target has to be a probability range when target_relative is TRUE"
    )
  } else {
    v$check(
      test_range(object@target),
      "target must be a numeric range"
    )
  }
  v$check(
    test_probability_range(object@overdose),
    "overdose has to be a probability range"
  )
  v$check(
    test_probability(object@max_overdose_prob, bounds_closed = FALSE),
    "max_overdose_prob must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@target_thresh),
    "target_thresh must be a probability value from [0, 1] interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestMinDist`] object
#'   contains valid `target` object.
v_next_best_min_dist <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestInfTheory`] object
#'   contains valid `target` and `asymmetry` objects.
v_next_best_inf_theory <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_number(object@asymmetry, finite = TRUE) &&
      h_in_range(object@asymmetry, c(0, 2), FALSE),
    "asymmetry must be a number from (0, 2) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestTD`] object
#'   contains valid `prob_target_drt` and `prob_target_eot` probabilities.
v_next_best_td <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@prob_target_drt, bounds_closed = FALSE),
    "prob_target_drt must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@prob_target_eot, bounds_closed = FALSE),
    "prob_target_eot must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestTDsamples`] object
#'   contains valid `derive` function.
v_next_best_td_samples <- function(object) {
  v <- Validate()
  v$check(
    test_function(object@derive, nargs = 1),
    "derive must have a single argument"
  )
  v$check(
    test_number(object@derive(1:5)),
    "derive must accept numerical vector as an argument and return a number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestMaxGainSamples`] object
#'   contains valid `derive` and `mg_derive` functions.
v_next_best_max_gain_samples <- function(object) {
  v <- Validate()
  v$check(
    test_function(object@derive, nargs = 1),
    "derive must have a single argument"
  )
  v$check(
    test_number(object@derive(1:5)),
    "derive must accept numerical vector as an argument and return a number"
  )
  v$check(
    test_function(object@mg_derive, nargs = 1),
    "mg_derive must have a single argument"
  )
  v$check(
    test_number(object@mg_derive(1:5)),
    "mg_derive must accept numerical vector as an argument and return a number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestProbMTDLTE`] object
#'   contains valid `target` probability and `method` string value.
v_next_best_prob_mtd_lte <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestProbMTDMinDist`] object
#'   contains valid `target` probability and `method` string value.
v_next_best_prob_mtd_min_dist <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$result()
}

# Increments ----

#' Internal Helper Functions for Validation of [`Increments`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`Increments`] or inherited classes and therefore not exported.
#'
#' @name v_increments
#' @param object (`Increments`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_increments validates that the [`IncrementsRelative`] object
#'   contains valid `intervals` and `increments` parameters.
v_increments_relative <- function(object) {
  v <- Validate()
  v$check(
    test_numeric(
      object@intervals,
      lower = 0,
      finite = TRUE,
      any.missing = FALSE,
      unique = TRUE,
      sorted = TRUE
    ),
    "intervals has to be a numerical vector with unique, finite, non-negative and sorted non-missing values"
  )
  v$check(
    test_numeric(
      object@increments,
      finite = TRUE,
      any.missing = FALSE,
      len = length(object@intervals)
    ),
    "increments has to be a numerical vector of the same length as `intervals` with finite values"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsRelativeParts`] object
#'   contains valid `dlt_start` and `clean_start` parameters.
v_increments_relative_parts <- function(object) {
  v <- Validate()
  is_dlt_start_ok <- test_int(object@dlt_start)
  v$check(is_dlt_start_ok, "dlt_start must be an integer number")
  if (is_dlt_start_ok) {
    v$check(
      test_int(object@clean_start, lower = object@dlt_start),
      "clean_start must be an integer number and it must be >= dlt_start"
    )
  }
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsRelativeDLT`] object
#'   contains valid `intervals` and `increments` parameters.
v_increments_relative_dlt <- function(object) {
  v <- Validate()
  v$check(
    test_integer(
      object@intervals,
      lower = 0,
      any.missing = FALSE,
      unique = TRUE,
      sorted = TRUE
    ),
    "intervals has to be an integer vector with unique, finite, non-negative and sorted non-missing values"
  )
  v$check(
    test_numeric(
      object@increments,
      finite = TRUE,
      any.missing = FALSE,
      len = length(object@intervals)
    ),
    "increments has to be a numerical vector of the same length as `intervals` with finite values"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsDoseLevels`] object
#'   contains valid `levels` and `basis_level` option.
v_increments_dose_levels <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@levels, lower = .Machine$double.xmin),
    "levels must be scalar positive integer"
  )
  v$check(
    test_string(object@basis_level, pattern = "^last$|^max$"),
    "basis_level must be either 'last' or 'max'"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsHSRBeta`]
#'   object contains valid probability target, threshold and shape parameters.
v_increments_hsr_beta <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$check(
    test_number(object@a, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter a must be a positive scalar"
  )
  v$check(
    test_number(object@b, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter b must be a positive scalar"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsMin`]
#'   object contains a list with `Increments` objects.
v_increments_min <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@increments_list, test_class, "Increments")),
    "all elements in increments_list must be of Increments class"
  )
  v$result()
}

#' @describeIn v_increments validates the [`IncrementsMaxToxProb`]
v_increments_maxtoxprob <- function(object) {
  v <- Validate()
  v$check(
    test_probabilities(object@prob),
    "prob must be a vector of probabilities with minimum length 1 and no missing values"
  )
  v$result()
}

# Stopping ----

#' Internal Helper Functions for Validation of [`Stopping`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`Stopping`] or inherited classes and therefore not exported.
#'
#' @name v_stopping
#' @param object (`Stopping`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_stopping validates that the [`StoppingCohortsNearDose`]
#'   object contains valid `nCohorts` and `percentage` parameters.
v_stopping_cohorts_near_dose <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nCohorts, lower = .Machine$double.xmin),
    "nCohorts must be positive integer scalar"
  )
  v$check(
    test_probability(object@percentage / 100),
    "percentage must be a number between 0 and 100"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingPatientsNearDose`]
#'   object contains valid `nPatients` and `percentage` parameters.
v_stopping_patients_near_dose <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nPatients, lower = .Machine$double.xmin),
    "nPatients must be positive integer scalar"
  )
  v$check(
    test_probability(object@percentage / 100),
    "percentage must be a number between 0 and 100"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMinCohorts`]
#'   object contains valid `nCohorts` parameter.
v_stopping_min_cohorts <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nCohorts, lower = .Machine$double.xmin),
    "nCohorts must be positive integer scalar"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMinPatients`]
#'   object contains valid `nPatients` parameter.
v_stopping_min_patients <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nPatients, lower = .Machine$double.xmin),
    "nPatients must be positive integer scalar"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingTargetProb`]
#'   object contains valid `target` and `prob` parameters.
v_stopping_target_prob <- function(object) {
  v <- Validate()
  v$check(
    test_probability_range(object@target),
    "target has to be a probability range"
  )
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMTDdistribution`]
#'   object contains valid `target`, `thresh` and `prob` parameters.
v_stopping_mtd_distribution <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@thresh, bounds_closed = FALSE),
    "thresh must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMTDCV`] object
#'   contains valid probability target and percentage threshold.
v_stopping_mtd_cv <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@thresh_cv / 100, bounds_closed = c(FALSE, TRUE)),
    "thresh_cv must be percentage > 0"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingTargetBiomarker`] object
#'   contains valid `target`, `is_relative` and `prob`slots.
v_stopping_target_biomarker <- function(object) {
  v <- Validate()
  v$check(
    test_flag(object@is_relative),
    "is_relative must be a flag"
  )
  if (isTRUE(object@is_relative)) {
    v$check(
      test_probability_range(object@target),
      "target has to be a probability range when is_relative flag is 'TRUE'"
    )
  } else {
    v$check(
      test_range(object@target, finite = TRUE),
      "target must be a numeric range"
    )
  }
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingList`] object
#'   contains valid `stop_list`, `summary` slots.
v_stopping_list <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@stop_list, test_class, "Stopping")),
    "every stop_list element must be of class 'Stopping'"
  )
  is_summary_ok <- test_function(object@summary, nargs = 1)
  v$check(
    is_summary_ok,
    "summary must be a function that accepts a single argument, without ..."
  )
  if (is_summary_ok) {
    summary_res <- object@summary(
      rep(c(TRUE, FALSE), length.out = length(object@stop_list))
    )
    v$check(
      test_flag(summary_res),
      "summary must accept a logical vector of the same length as 'stop_list' and return a boolean value"
    )
  }
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingAll`] object
#'   contains valid `stop_list` slot.
v_stopping_all <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@stop_list, test_class, "Stopping")),
    "every stop_list element must be of class 'Stopping'"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingTDCIRatio`] object
#'   contains valid `target_ratio` and  `prob_target` slots.
v_stopping_tdci_ratio <- function(object) {
  v <- Validate()
  v$check(
    test_number(
      object@target_ratio,
      lower = .Machine$double.xmin,
      finite = TRUE
    ),
    "target_ratio must be a positive number"
  )
  v$check(
    test_probability(object@prob_target),
    "prob_target must be a probability value from [0, 1] interval"
  )
  v$result()
}

# CohortSize ----

#' Internal Helper Functions for Validation of [`CohortSize`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`CohortSize`] or inherited classes and therefore not exported.
#'
#' @name v_cohort_size
#' @param object (`CohortSize`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_cohort_size validates that the [`CohortSizeRange`] object
#'   contains valid `intervals` and  `cohort_size` slots.
v_cohort_size_range <- function(object) {
  v <- Validate()
  v$check(
    test_numeric(
      object@intervals,
      lower = 0,
      finite = TRUE,
      any.missing = FALSE,
      min.len = 1,
      unique = TRUE,
      sorted = TRUE
    ),
    "intervals must be a numeric vector with non-negative, sorted (asc.) and unique values"
  )
  v$check(
    test_integer(
      object@cohort_size,
      lower = 0,
      any.missing = FALSE,
      len = length(object@intervals)
    ),
    "cohort_size must be an integer vector of the same length as intervals, containing non-negative values only"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeDLT`] object
#'   contains valid `intervals` and  `cohort_size` slots.
v_cohort_size_dlt <- function(object) {
  v <- Validate()
  v$check(
    test_integer(
      object@intervals,
      lower = 0,
      any.missing = FALSE,
      min.len = 1,
      unique = TRUE,
      sorted = TRUE
    ),
    "intervals must be an integer vector with non-negative, sorted (asc.) and unique values"
  )
  v$check(
    test_integer(
      object@cohort_size,
      lower = 0,
      any.missing = FALSE,
      len = length(object@intervals)
    ),
    "cohort_size must be an integer vector of the same length as intervals, containing non-negative values only"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeConst`] object
#'   contains valid `size` slot.
v_cohort_size_const <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@size, lower = 0),
    "size needs to be a non-negative scalar"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeParts`] object
#'   contains valid `sizes` slot.
v_cohort_size_parts <- function(object) {
  v <- Validate()
  v$check(
    test_integer(
      object@cohort_sizes,
      lower = .Machine$double.xmin,
      any.missing = FALSE,
      len = 2
    ),
    "cohort_sizes needs to be an integer vector of length 2 with all elements positive"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeMax`] object
#'   contains valid `cohort_sizes` slot.
v_cohort_size_max <- function(object) {
  v <- Validate()
  v$check(
    test_list(
      object@cohort_sizes,
      types = "CohortSize",
      any.missing = FALSE,
      min.len = 2,
      unique = TRUE
    ),
    "cohort_sizes must be a list of CohortSize (unique) objects only and be of length >= 2"
  )
  v$result()
}

# SafetyWindow ----

#' Internal Helper Functions for Validation of [`SafetyWindow`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`SafetyWindow`] or inherited classes and therefore not exported.
#'
#' @name v_safety_window
#' @param object (`SafetyWindow`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_safety_window validates that the [`SafetyWindowSize`] object
#'   contains valid slots.
v_safety_window_size <- function(object) {
  v <- Validate()
  v$check(
    test_list(object@gap, types = "integer", any.missing = FALSE, min.len = 1),
    "gap must be a list of length >= 1 with integer vectors only"
  )
  v$check(
    all(sapply(
      object@gap,
      test_integer,
      lower = 0,
      any.missing = FALSE,
      min.len = 1
    )),
    "every element in gap list has to be an integer vector with non-negative and non-missing values"
  )
  pg_len <- length(object@gap)
  v$check(
    test_integer(
      object@size,
      lower = .Machine$double.xmin,
      any.missing = FALSE,
      len = pg_len,
      unique = TRUE,
      sorted = TRUE
    ),
    "size has to be an integer vector, of the same length as gap, with positive, unique and sorted non-missing values"
  )
  v$check(
    test_int(object@follow, lower = .Machine$double.xmin),
    "follow has to be a positive integer number"
  )
  v$check(
    test_int(object@follow_min, lower = .Machine$double.xmin),
    "follow_min has to be a positive integer number"
  )
  v$result()
}

#' @describeIn v_safety_window validates that the [`SafetyWindowConst`] object
#'   contains valid slots.
v_safety_window_const <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@gap, lower = 0, any.missing = FALSE),
    "gap has to be an integer vector with non-negative and non-missing elements"
  )
  v$check(
    test_int(object@follow, lower = .Machine$double.xmin),
    "follow has to be a positive integer number"
  )
  v$check(
    test_int(object@follow_min, lower = .Machine$double.xmin),
    "follow_min has to be a positive integer number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestOrdinal`] object
#'   contains valid `grade` and standard `NextBest` rule.
v_next_best_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@grade, lower = 1),
    "grade must be a positive integer"
  )
  v$check(
    test_class(object@rule, "NextBest"),
    "rule must be a NextBest object"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsOrdinal`] object
#'   contains valid `grade` and standard `Increments` rule.
v_increments_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@grade, lower = 1),
    "grade must be a positive integer"
  )
  v$check(
    test_class(object@rule, "Increments"),
    "rule must be a Increments object"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`CohortSizeOrdinal`] object
#'   contains valid `grade` and standard `CohortSize` rule.
v_cohort_size_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@grade, lower = 1),
    "grade must be a positive integer"
  )
  v$check(
    test_class(object@rule, "CohortSize"),
    "rule must be a CohortSize object"
  )
  v$result()
}

#' @include Model-class.R
#' @include Samples-class.R
NULL

# doseFunction ----

## generic ----

#' Getting the Dose Function for a Given Model Type
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A function that returns a [dose()] method that computes the dose reaching a
#' specific target value of a given independent variable, based on the model
#' specific parameters.
#'
#' @param model (`GeneralModel` or `ModelPseudo`)\cr the model.
#' @param ... model specific parameters.
#'
#' @return A [dose()] method that computes doses.
#'
#' @seealso [dose()], [probFunction()].
#'
#' @export
#' @example examples/Model-method-doseFunction.R
#'
setGeneric(
  name = "doseFunction",
  def = function(model, ...) {
    standardGeneric("doseFunction")
  },
  valueClass = "function"
)

## GeneralModel ----

#' @describeIn doseFunction
#'
#' @aliases doseFunction-GeneralModel
#' @export
#'
setMethod(
  f = "doseFunction",
  signature = "GeneralModel",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_subset(names(model_params), model@sample, empty.ok = FALSE)

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = NROW(model_params[[1]]))
    )
    function(x, ...) {
      dose(x = x, model = model, samples = samples, ...)
    }
  }
)

## ModelPseudo ----

#' @describeIn doseFunction
#'
#' @aliases doseFunction-ModelPseudo
#' @export
#'
setMethod(
  f = "doseFunction",
  signature = "ModelPseudo",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_character(
      names(model_params),
      len = length(model_params),
      any.missing = FALSE,
      unique = TRUE
    )

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(x) {
      dose(x = x, model = model, samples = samples)
    }
  }
)

## LogisticLogNormalOrdinal ----

#' @describeIn doseFunction
#'
#' @param grade (`integer`)\cr the toxicity grade for which the dose function is
#' required
#'
#' @aliases doseFunction-LogisticLogNormalOrdinal
#' @example examples/Model-method-doseFunctionLogisticLogNormalOrdinal.R
#' @export
setMethod(
  f = "doseFunction",
  signature = "LogisticLogNormalOrdinal",
  definition = function(model, grade, ...) {
    model_params <- list(...)
    assert_character(
      names(model_params),
      len = length(model_params),
      any.missing = FALSE,
      unique = TRUE
    )
    assert_integer(grade, lower = 1, len = 1)
    coll <- makeAssertCollection()
    if (!(paste0("alpha", grade) %in% names(model_params))) {
      coll$push(
        paste0(
          "Since grade = ",
          grade,
          ", a parameter named 'alpha",
          grade,
          "' must appear the call"
        )
      )
    }
    reportAssertions(coll)
    # Create dummy intercept columns if necessary
    for (g in seq_along(grade)) {
      if (!(paste0("alpha", g) %in% names(model_params))) {
        model_params[[paste0("alpha", g)]] <- rep(0, length(model_params[[1]]))
      }
    }

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(x) {
      dose(x = x, model = model, samples = samples, grade = grade)
    }
  }
)

# probFunction ----

## generic ----

#' Getting the Prob Function for a Given Model Type
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A function that returns a [prob()] function that computes the toxicity
#' probabilities for a given dose level, based on the model specific parameters.
#'
#' @param model (`GeneralModel` or `ModelTox`)\cr the model.
#' @param ... model specific parameters.
#'
#' @return A [prob()] function that computes toxicity probabilities.
#'
#' @seealso [prob()], [doseFunction()].
#'
#' @export
#' @example examples/Model-method-probFunction.R
#'
setGeneric(
  name = "probFunction",
  def = function(model, ...) {
    standardGeneric("probFunction")
  },
  valueClass = "function"
)

## GeneralModel ----

#' @describeIn probFunction
#'
#' @aliases probFunction-GeneralModel
#' @export
#'
setMethod(
  f = "probFunction",
  signature = "GeneralModel",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_subset(names(model_params), model@sample, empty.ok = FALSE)

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = NROW(model_params[[1]]))
    )
    function(dose, ...) {
      prob(dose = dose, model = model, samples = samples, ...)
    }
  }
)

## ModelTox ----

#' @describeIn probFunction
#'
#' @aliases probFunction-ModelTox
#' @export
#'
setMethod(
  f = "probFunction",
  signature = "ModelTox",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_character(
      names(model_params),
      len = length(model_params),
      any.missing = FALSE,
      unique = TRUE
    )

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(dose) {
      prob(dose = dose, model = model, samples = samples)
    }
  }
)

## LogisticLogNormalOrdinal ----

#' @describeIn probFunction
#'
#' @param grade (`integer`)\cr the toxicity grade for which the dose function is
#' required
#'
#' @aliases probFunction-LogisticLogNormalOrdinal
#' @example examples/Model-method-probFunctionLogisticLogNormalOrdinal.R
#' @export
setMethod(
  f = "probFunction",
  signature = "LogisticLogNormalOrdinal",
  definition = function(model, grade, ...) {
    model_params <- list(...)
    assert_character(
      names(model_params),
      len = length(model_params),
      any.missing = FALSE,
      unique = TRUE
    )
    assert_integer(grade, lower = 1, len = 1)
    coll <- makeAssertCollection()
    if (!(paste0("alpha", grade) %in% names(model_params))) {
      coll$push(
        paste0(
          "Since grade = ",
          grade,
          ", a parameter named 'alpha",
          grade,
          "' must appear the call"
        )
      )
    }
    reportAssertions(coll)
    # Create dummy intercept columns if necessary
    for (g in seq_along(grade)) {
      if (!(paste0("alpha", g) %in% names(model_params))) {
        model_params[[paste0("alpha", g)]] <- rep(0, length(model_params[[1]]))
      }
    }

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(dose) {
      prob(dose = dose, model = model, samples = samples, grade = grade)
    }
  }
)


# efficacyFunction ----

## generic ----

#' Getting the Efficacy Function for a Given Model Type
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A function that returns an [efficacy()] function that computes expected
#' efficacy for a given dose level, based on the model specific parameters.
#'
#' @param model (`ModelEff`)\cr the model.
#' @param ... model specific parameters.
#'
#' @return A [efficacy()] function that computes expected efficacy.
#'
#' @seealso [efficacy()].
#'
#' @export
#' @example examples/Model-method-efficacyFunction.R
#'
setGeneric(
  name = "efficacyFunction",
  def = function(model, ...) {
    standardGeneric("efficacyFunction")
  },
  valueClass = "function"
)

## ModelEff ----

#' @describeIn efficacyFunction
#'
#' @aliases efficacyFunction-ModelEff
#' @export
#'
setMethod(
  f = "efficacyFunction",
  signature = "ModelEff",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_character(
      names(model_params),
      len = length(model_params),
      any.missing = FALSE,
      unique = TRUE
    )

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = NROW(model_params[[1]]))
    )
    function(dose) {
      efficacy(dose = dose, model = model, samples = samples)
    }
  }
)

# dose ----

## generic ----

#' Computing the Doses for a given independent variable, Model and Samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the dose reaching a specific target value of a
#' given variable that dose depends on. The meaning of this variable depends
#' on the type of the model. For instance, for single agent dose escalation
#' model or pseudo DLE (dose-limiting events)/toxicity model, this variable
#' represents the a probability of the occurrence of a DLE. For efficacy models,
#' it represents expected efficacy.
#' The doses are computed based on the samples of the model parameters (samples).
#'
#' @details The `dose()` function computes the doses corresponding to a value of
#'   a given independent variable, using samples of the model parameter(s).
#'   If you work with multivariate model parameters, then assume that your model
#'   specific `dose()` method receives a samples matrix where the rows
#'   correspond to the sampling index, i.e. the layout is then
#'   `nSamples x dimParameter`.
#'
#' @note The [dose()] and [prob()] methods are the inverse of each other, for
#'   all [dose()] methods for which its first argument, i.e. a given independent
#'   variable that dose depends on, represents toxicity probability.
#'
#' @param x (`proportion` or `numeric`)\cr a value of an independent variable
#'   on which dose depends.
#'   The following recycling rule applies when `samples` is not missing: vectors
#'   of size 1 will be recycled to the size of the sample
#'   (i.e. `size(samples)`). Otherwise, `x` must have the same size
#'   as the sample.
#' @param model (`GeneralModel` or `ModelPseudo`)\cr the model.
#' @param samples (`Samples`)\cr the samples of model's parameters that will be
#'   used to compute the resulting doses. Can also be missing for some models.
#' @param ... model specific parameters when `samples` are not used.
#'
#' @return A `number` or `numeric` vector with the doses.
#'   If non-scalar `samples` were used, then every element in the returned vector
#'   corresponds to one element of a sample. Hence, in this case, the output
#'   vector is of the same length as the sample vector. If scalar `samples` were
#'   used or no `samples` were used, e.g. for pseudo DLE/toxicity `model`,
#'   then the output is of the same length as the length of the `prob`.
#'
#' @seealso [doseFunction()], [prob()], [efficacy()].
#'
#' @export
#' @example examples/Model-method-dose.R
#'
setGeneric(
  name = "dose",
  def = function(x, model, samples, ...) {
    standardGeneric("dose")
  },
  valueClass = "numeric"
)

## LogisticNormal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticNormal
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticNormal",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticLogNormal
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormal",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormalOrdinal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' In the case of a `LogisticLogNormalOrdinal` model, `dose` returns only the
#' probability of toxicity at the given grade or higher
#'
#' @param grade (`integer`)\cr The toxicity grade for which probabilities are required
#'
#' @aliases dose-LogisticLogNormalOrdinal
#' @example examples/Model-method-doseLogisticLogNormalOrdinal.R
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalOrdinal",
    samples = "Samples"
  ),
  definition = function(x, model, samples, grade) {
    assert_probabilities(x)
    assert_length(x, len = size(samples))
    assert_integer(
      grade,
      len = 1,
      lower = 1,
      upper = (length(names(samples@data)) - 1)
    )
    a <- paste0("alpha", grade)
    assert_subset(c(a, "beta"), names(samples))

    alpha <- samples@data[[a]]
    beta <- samples@data$beta
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha) / beta) * ref_dose
  }
)

## LogisticLogNormalSub ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticLogNormalSub
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalSub",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- model@ref_dose
    ((logit(x) - alpha0) / alpha1) + ref_dose
  }
)

## ProbitLogNormal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-ProbitLogNormal
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "ProbitLogNormal",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((probit(x) - alpha0) / alpha1) * ref_dose
  }
)

## ProbitLogNormalRel ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-ProbitLogNormalRel
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "ProbitLogNormalRel",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    ((probit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormalGrouped ----

#' @describeIn dose method for [`LogisticLogNormalGrouped`] which needs `group`
#'   argument in addition.
#' @param group (`character` or `factor`)\cr for [`LogisticLogNormalGrouped`],
#'   indicating whether to calculate the dose for the `mono` or for
#'   the `combo` arm.
#' @aliases dose-LogisticLogNormalGrouped
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalGrouped",
    samples = "Samples"
  ),
  definition = function(x, model, samples, group) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "delta0", "alpha1", "delta1"), names(samples))
    assert_length(x, len = size(samples))
    assert_multi_class(group, c("character", "factor"))
    assert_subset(as.character(group), choices = c("mono", "combo"))
    assert_length(group, len = size(samples))

    alpha0 <- samples@data$alpha0
    delta0 <- samples@data$delta0
    alpha1 <- samples@data$alpha1
    delta1 <- samples@data$delta1
    ref_dose <- as.numeric(model@ref_dose)
    is_combo <- as.integer(group == "combo")
    exp(
      (logit(x) - (alpha0 + is_combo * delta0)) / (alpha1 + is_combo * delta1)
    ) *
      ref_dose
  }
)

## LogisticKadane ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticKadane
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticKadane",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(x, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma * (logit(x) - logit(rho0)) + xmin * (logit(theta) - logit(x))
    num / (logit(theta) - logit(rho0))
  }
)

## LogisticKadaneBetaGamma ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticKadaneBetaGamma
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticKadaneBetaGamma",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(x, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma * (logit(x) - logit(rho0)) + xmin * (logit(theta) - logit(x))
    num / (logit(theta) - logit(rho0))
  }
)

## LogisticNormalMixture ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticNormalMixture
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticNormalMixture",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticNormalFixedMixture ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticNormalFixedMixture
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticNormalFixedMixture",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormalMixture ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticLogNormalMixture
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalMixture",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    stop("not implemented")
  }
)

## DualEndpoint ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-DualEndpoint
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "DualEndpoint",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset("betaZ", names(samples))
    assert_length(x, len = size(samples))

    betaZ <- samples@data$betaZ
    ref_dose <- as.numeric(model@ref_dose)
    dose_temp <- (qnorm(x) - betaZ[, 1]) / betaZ[, 2]
    if (model@use_log_dose) {
      exp(dose_temp) * ref_dose
    } else {
      dose_temp * ref_dose
    }
  }
)

## LogisticIndepBeta ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticIndepBeta
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticIndepBeta",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("phi1", "phi2"), names(samples))
    assert_length(x, len = size(samples))

    phi1 <- samples@data$phi1
    phi2 <- samples@data$phi2
    log_dose <- (log(x / (1 - x)) - phi1) / phi2
    exp(log_dose)
  }
)

## LogisticIndepBeta-noSamples ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'   All model parameters (except `x`) should be present in the `model` object.
#'
#' @aliases dose-LogisticIndepBeta-noSamples
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticIndepBeta",
    samples = "missing"
  ),
  definition = function(x, model) {
    assert_probabilities(x)
    model_params <- h_slots(model, c("phi1", "phi2"))
    nsamples <- length(model_params[[1]])
    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = nsamples)
    )
    assert_length(x, len = nsamples)

    dose(x, model, samples)
  }
)

## Effloglog-noSamples ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'   All model parameters (except `x`) should be present in the `model` object.
#'
#' @aliases dose-Effloglog-noSamples
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "Effloglog",
    samples = "missing"
  ),
  definition = function(x, model) {
    assert_numeric(x, min.len = 1L, any.missing = FALSE, finite = TRUE)
    theta1 <- model@theta1
    theta2 <- model@theta2
    constant <- model@const
    assert_scalar(theta1)
    assert_scalar(theta2)
    assert_scalar(constant)

    exp(exp((x - theta1) / theta2)) - constant
  }
)

## EffFlexi ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`). For this method `x` must
#'   be a scalar.
#'
#' @aliases dose-EffFlexi
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "EffFlexi",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_number(x)
    assert_subset("ExpEff", names(samples))

    samples_efficacy <- samples@data$ExpEff
    dose_grid <- model@data@doseGrid

    # Find dose level for a given expected efficacy level using linear interpolation.
    apply(samples_efficacy, 1, function(se) {
      se_leq_x <- se <= x
      dose_level0 <- max(which(se_leq_x))
      dose_level1 <- min(which(!se_leq_x))
      eff0 <- se[dose_level0]
      eff1 <- se[dose_level1]
      dose0 <- dose_grid[dose_level0]
      dose1 <- dose_grid[dose_level1]
      dose0 + (dose1 - dose0) * ((x - eff0) / (eff1 - eff0))
    })
  }
)

## OneParLogNormalPrior ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLT (`x`).
#'
#' @aliases dose-OneParLogNormalPrior
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "OneParLogNormalPrior",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset("alpha", names(samples))
    assert_length(x, len = size(samples))

    alpha <- samples@data$alpha
    skel_fun_inv <- model@skel_fun_inv
    skel_fun_inv(x^(1 / exp(alpha)))
  }
)

## OneParExpPrior ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLT (`x`).
#'
#' @aliases dose-OneParExpPrior
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "OneParExpPrior",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset("theta", names(samples))
    assert_length(x, len = size(samples))

    theta <- samples@data$theta
    skel_fun_inv <- model@skel_fun_inv
    assert_numeric(theta, lower = .Machine$double.xmin, finite = TRUE)
    skel_fun_inv(x^(1 / theta))
  }
)

# prob ----

## generic ----

#' Computing Toxicity Probabilities for a Given Dose, Model and Samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the probability of the occurrence of a DLE at a
#' specified dose level, based on the model parameters (samples).
#'
#' @details The `prob()` function computes the probability of toxicity for given
#'   doses, using samples of the model parameter(s).
#'   If you work with multivariate model parameters, then assume that your model
#'   specific `prob()` method receives a samples matrix where the rows
#'   correspond to the sampling index, i.e. the layout is then
#'   `nSamples x dimParameter`.
#'
#' @note The [prob()] and [dose()] functions are the inverse of
#'   each other, for all [dose()] methods for which its first argument, i.e. a
#'   given independent variable that dose depends on, represents toxicity
#'   probability.
#'
#' @param dose (`number` or `numeric`)\cr the dose which is targeted.
#'   The following recycling rule applies when `samples` is not missing: vectors
#'   of size 1 will be recycled to the size of the sample
#'   (i.e. `size(samples)`). Otherwise, `dose` must have the same
#'   size as the sample.
#' @param model (`GeneralModel` or `ModelTox`)\cr the model for single agent
#'   dose escalation or pseudo DLE (dose-limiting events)/toxicity model.
#' @param samples (`Samples`)\cr the samples of model's parameters that will be
#'   used to compute toxicity probabilities. Can also be missing for some models.
#' @param ... model specific parameters when `samples` are not used.
#'
#' @return A `proportion` or `numeric` vector with the toxicity probabilities.
#'   If non-scalar `samples` were used, then every element in the returned vector
#'   corresponds to one element of a sample. Hence, in this case, the output
#'   vector is of the same length as the sample vector. If scalar `samples` were
#'   used or no `samples` were used, e.g. for pseudo DLE/toxicity `model`,
#'   then the output is of the same length as the length of the `dose`.  In the
#'   case of `LogisticLogNormalOrdinal`, the probabilities relate to toxicities
#'   of  grade given by `grade`.
#'
#' @seealso [probFunction()], [dose()], [efficacy()].
#'
#' @export
#' @example examples/Model-method-prob.R
#'
setGeneric(
  name = "prob",
  def = function(dose, model, samples, ...) {
    standardGeneric("prob")
  },
  valueClass = c("numeric", "list")
)

## LogisticNormal ----

#' @describeIn prob
#'
#' @aliases prob-LogisticNormal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticNormal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticLogNormal ----

#' @describeIn prob
#'
#' @aliases prob-LogisticLogNormal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticLogNormalSub ----

#' @describeIn prob
#'
#' @aliases prob-LogisticLogNormalSub
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalSub",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- model@ref_dose
    plogis(alpha0 + alpha1 * (dose - ref_dose))
  }
)

## ProbitLogNormal ----

#' @describeIn prob
#'
#' @aliases prob-ProbitLogNormal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "ProbitLogNormal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    pnorm(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## ProbitLogNormalRel ----

#' @describeIn prob
#'
#' @aliases prob-ProbitLogNormalRel
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "ProbitLogNormalRel",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    pnorm(alpha0 + alpha1 * (dose / ref_dose))
  }
)

## LogisticLogNormalGrouped ----

#' @describeIn prob method for [`LogisticLogNormalGrouped`] which needs `group`
#'   argument in addition.
#' @param group (`character` or `factor`)\cr for [`LogisticLogNormalGrouped`],
#'   indicating whether to calculate the probability for the `mono` or for
#'   the `combo` arm.
#' @aliases prob-LogisticLogNormalGrouped
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalGrouped",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, group, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "delta0", "alpha1", "delta1"), names(samples))
    assert_length(dose, len = size(samples))
    assert_multi_class(group, c("character", "factor"))
    assert_subset(as.character(group), choices = c("mono", "combo"))
    assert_length(group, len = size(samples))

    alpha0 <- samples@data$alpha0
    delta0 <- samples@data$delta0
    alpha1 <- samples@data$alpha1
    delta1 <- samples@data$delta1
    ref_dose <- as.numeric(model@ref_dose)
    is_combo <- as.integer(group == "combo")
    plogis(
      (alpha0 + is_combo * delta0) +
        (alpha1 + is_combo * delta1) * log(dose / ref_dose)
    )
  }
)

## LogisticKadane ----

#' @describeIn prob
#'
#' @aliases prob-LogisticKadane
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticKadane",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(dose, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma *
      logit(rho0) -
      xmin * logit(theta) +
      (logit(theta) - logit(rho0)) * dose
    plogis(num / (gamma - xmin))
  }
)

## LogisticKadaneBetaGamma ----

#' @describeIn prob
#'
#' @aliases prob-LogisticKadaneBetaGamma
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticKadaneBetaGamma",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(dose, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma *
      logit(rho0) -
      xmin * logit(theta) +
      (logit(theta) - logit(rho0)) * dose
    plogis(num / (gamma - xmin))
  }
)

## LogisticNormalMixture ----

#' @describeIn prob
#'
#' @aliases prob-LogisticNormalMixture
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticNormalMixture",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticNormalFixedMixture ----

#' @describeIn prob
#'
#' @aliases prob-LogisticNormalFixedMixture
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticNormalFixedMixture",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticLogNormalMixture ----

#' @describeIn prob
#'
#' @aliases prob-LogisticLogNormalMixture
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalMixture",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    comp <- samples@data$comp
    ref_dose <- as.numeric(model@ref_dose)
    sel <- cbind(seq_along(comp), comp)
    plogis(alpha0[sel] + alpha1[sel] * log(dose / ref_dose))
  }
)

## DualEndpoint ----

#' @describeIn prob
#'
#' @aliases prob-DualEndpoint
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "DualEndpoint",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset("betaZ", names(samples))
    assert_length(dose, len = size(samples))

    betaZ <- samples@data$betaZ
    ref_dose <- as.numeric(model@ref_dose)
    stand_dose <- if (model@use_log_dose) {
      log(dose / ref_dose)
    } else {
      dose / ref_dose
    }
    pnorm(betaZ[, 1] + betaZ[, 2] * stand_dose)
  }
)

## LogisticIndepBeta ----

#' @describeIn prob compute toxicity probabilities of the occurrence of a DLE at
#' a specified dose level, based on the samples of [`LogisticIndepBeta`] model
#' parameters.
#'
#' @aliases prob-LogisticIndepBeta
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticIndepBeta",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("phi1", "phi2"), names(samples))
    assert_length(dose, len = size(samples))

    phi1 <- samples@data$phi1
    phi2 <- samples@data$phi2
    log_dose <- log(dose)
    exp(phi1 + phi2 * log_dose) / (1 + exp(phi1 + phi2 * log_dose))
  }
)

## LogisticIndepBeta-noSamples ----

#' @describeIn prob compute toxicity probabilities of the occurrence of a DLE at
#' a specified dose level, based on the [`LogisticIndepBeta`] model parameters.
#' All model parameters (except `dose`) should be present in the `model` object.
#'
#' @aliases prob-LogisticIndepBeta-noSamples
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticIndepBeta",
    samples = "missing"
  ),
  definition = function(dose, model, ...) {
    model_params <- h_slots(model, c("phi1", "phi2"))
    nsamples <- length(model_params[[1]])
    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = nsamples)
    )

    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_length(dose, len = nsamples)

    prob(dose, model, samples)
  }
)

## OneParLogNormalPrior ----

#' @describeIn prob
#'
#' @aliases prob-OneParLogNormalPrior
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "OneParLogNormalPrior",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset("alpha", names(samples))
    assert_length(dose, len = size(samples))

    alpha <- samples@data$alpha
    skel_fun <- model@skel_fun
    skel_fun(dose)^exp(alpha)
  }
)

## OneParExpPrior ----

#' @describeIn prob
#'
#' @aliases prob-OneParExpPrior
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "OneParExpPrior",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset("theta", names(samples))
    assert_length(dose, len = size(samples))

    theta <- samples@data$theta
    skel_fun <- model@skel_fun
    skel_fun(dose)^theta
  }
)

## LogisticLogNormalOrdinal ----

#' Calculate a grade-specific probability of toxicity for a given dose.
#' @describeIn prob
#'
#' @param grade (`integer` or `integer_vector`)\cr The toxicity grade for which probabilities are required
#' @param cumulative (`flag`)\cr Should the returned probability be cumulative
#' (the default) or grade-specific?
#' @aliases prob-LogisticLogNormalOrdinal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalOrdinal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, grade, cumulative = TRUE, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_integer(
      grade,
      min.len = 1,
      max.len = length(model@params@mean) - 1,
      lower = 0,
      upper = length(model@params@mean) - 1
    )
    assert_subset(
      names(samples),
      c(paste0("alpha", 0:(length(model@params@mean) - 1)), "beta")
    )
    assert_length(dose, len = size(samples))
    assert_flag(cumulative)

    rv <- lapply(
      grade,
      function(g) {
        alpha <- samples@data[[paste0("alpha", g)]]
        beta <- samples@data$beta
        ref_dose <- as.numeric(model@ref_dose)

        cumulative_prob <- plogis(alpha + beta * log(dose / ref_dose))
        if (cumulative | g == as.integer(length(model@params@mean) - 1)) {
          return(cumulative_prob)
        }

        # Calculate grade-specific probabilities
        alpha0 <- samples@data[[paste0("alpha", g + 1)]]
        grade_prob <- cumulative_prob -
          plogis(alpha0 + beta * log(dose / ref_dose))
        return(grade_prob)
      }
    )
    if (length(rv) == 1) {
      return(rv[[1]])
    }
    names(rv) <- as.character(grade)
    return(rv)
  }
)

# efficacy ----

## generic ----

#' Computing Expected Efficacy for a Given Dose, Model and Samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the value of expected efficacy at a specified dose
#' level, based on the model specific parameters. The model parameters (samples)
#' are obtained based on prior specified in form of pseudo data combined with
#' observed responses (if any).
#'
#' @details The `efficacy()` function computes the expected efficacy for given
#'   doses, using samples of the model parameter(s).
#'   If you work with multivariate model parameters, then assume that your model
#'   specific `efficacy()` method receives a samples matrix where the rows
#'   correspond to the sampling index, i.e. the layout is then
#'   `nSamples x dimParameter`.
#'
#' @param dose (`numeric`)\cr the dose which is targeted.
#'   The following recycling rule applies when `samples` is not missing: vectors
#'   of size 1 will be recycled to the size of the sample
#'   (i.e. `size(samples)`). Otherwise, `dose` must have the same
#'   size as the sample.
#' @param model (`ModelEff`)\cr the efficacy model with pseudo data prior.
#' @param samples (`Samples`)\cr samples of model's parameters that will be
#'   used to compute expected efficacy values. Can also be missing for some
#'   models.
#' @param ... model specific parameters when `samples` are not used.
#'
#' @return A `numeric` vector with the values of expected efficacy.
#'   If non-scalar `samples` were used, then every element in the returned vector
#'   corresponds to one element of a sample. Hence, in this case, the output
#'   vector is of the same length as the sample vector. If scalar `samples` were
#'   used or no `samples` were used, e.g. for pseudo DLE/toxicity `model`,
#'   then the output is of the same length as the length of the `dose`.
#'
#' @seealso [dose()], [prob()].
#'
#' @export
#' @example examples/Model-method-efficacy.R
setGeneric(
  name = "efficacy",
  def = function(dose, model, samples, ...) {
    standardGeneric("efficacy")
  },
  valueClass = "numeric"
)

## Effloglog ----

#' @describeIn efficacy compute the expected efficacy at a specified dose level,
#' based on the samples of [`Effloglog`] model parameters.
#'
#' @aliases efficacy-Effloglog
#' @export
#'
setMethod(
  f = "efficacy",
  signature = signature(
    dose = "numeric",
    model = "Effloglog",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("theta1", "theta2"), names(samples))
    assert_length(dose, len = size(samples))

    theta1 <- samples@data$theta1
    theta2 <- samples@data$theta2
    constant <- model@const
    theta1 + theta2 * log(log(dose + constant))
  }
)

## Effloglog-noSamples ----

#' @describeIn efficacy compute the expected efficacy at a specified dose level,
#' based on the [`Effloglog`] model parameters.
#' All model parameters (except `dose`) should be present in the `model` object.
#'
#' @aliases efficacy-Effloglog-noSamples
#' @export
#'
setMethod(
  f = "efficacy",
  signature = signature(
    dose = "numeric",
    model = "Effloglog",
    samples = "missing"
  ),
  definition = function(dose, model) {
    model_params <- h_slots(model, c("theta1", "theta2"))
    nsamples <- length(model_params[[1]])
    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = nsamples)
    )

    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_length(dose, len = nsamples)

    efficacy(dose, model, samples)
  }
)

## EffFlexi ----

#' @describeIn efficacy compute the expected efficacy at a specified dose level,
#' based on the samples of [`EffFlexi`] model parameters. If a given dose in
#' the `dose` vector is from outside of the dose grid range, the `NA_real` is
#' returned for this dose and the warning is thrown.
#'
#' @aliases efficacy-EffFlexi
#' @export
#'
setMethod(
  f = "efficacy",
  signature = signature(
    dose = "numeric",
    model = "EffFlexi",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    n_samples <- size(samples)
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_true(model@data@nGrid >= 1L)
    assert_subset("ExpEff", names(samples))
    assert_length(dose, len = n_samples)

    dose_grid <- model@data@doseGrid
    dose_level <- match_within_tolerance(dose, dose_grid)
    dose[which(!is.na(dose_level))] <- dose_grid[stats::na.omit(dose_level)]

    # linear interpolation, NA for doses that are outside of the dose_grid range.
    samples_eff <- samples@data$ExpEff
    eff <- if (length(dose) == n_samples) {
      sapply(seq_len(n_samples), function(s) {
        stats::approx(dose_grid, samples_eff[s, ], xout = dose[s])$y
      })
    } else {
      eff <- apply(samples_eff, 1, function(s) {
        stats::approx(dose_grid, s, xout = dose)$y
      })
      as.vector(eff)
    }

    if (any(is.na(eff))) {
      warning(
        paste(
          "At least one dose out of",
          paste(dose, collapse = ", "),
          "is outside of the dose grid range"
        )
      )
    }
    eff
  }
)

# biomarker ----

## generic ----

#' Get the Biomarker Levels for a Given Dual-Endpoint Model, Given Dose Levels and Samples
#'
#' @details This function simply returns a specific columns (with the indices equal
#' to `xLevel`) of the biomarker samples matrix, which is included in the the
#' `samples` object.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @param xLevel (`integer`)\cr the levels for the doses the patients have been
#'   given w.r.t dose grid. See [`Data`] for more details.
#' @param model (`DualEndpoint`)\cr the model.
#' @param samples (`Samples`)\cr the samples of model's parameters that store
#'   the value of biomarker levels for all doses on the dose grid.
#' @param ... not used.
#'
#' @return The biomarker levels.
#'
#' @export
#' @example examples/Model-method-biomarker.R
#'
setGeneric(
  name = "biomarker",
  def = function(xLevel, model, samples, ...) {
    standardGeneric("biomarker")
  },
  valueClass = c("numeric", "array")
)

## DualEndpoint ----

#' @describeIn biomarker
#'
#' @aliases biomarker-DualEndpoint
#' @export
#'
setMethod(
  f = "biomarker",
  signature = signature(
    xLevel = "integer",
    model = "DualEndpoint",
    samples = "Samples"
  ),
  def = function(xLevel, model, samples, ...) {
    assert_integer(
      xLevel,
      lower = 1,
      upper = ncol(samples@data$betaW),
      any.missing = FALSE,
      min.len = 1
    )

    samples@data$betaW[, xLevel]
  }
)

# gain ----

## generic ----

#' Compute Gain Values based on Pseudo DLE and a Pseudo Efficacy Models and
#' Using Optional Samples.
#'
#' @details This function computes the gain values for a given dose level,
#' pseudo DLE and Efficacy models as well as a given DLE and Efficacy samples.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param dose (`number` or `numeric`)\cr the dose which is targeted.
#'   The following recycling rule applies when samples are not missing: vectors
#'   of size 1 will be recycled to the size of the sample. Otherwise, `dose`
#'   must have the same size as the sample.
#' @param model_dle (`ModelTox`)\cr pseudo DLE (dose-limiting events)/toxicity
#'   model.
#' @param samples_dle (`Samples`)\cr the samples of model's
#'   parameters that will be used to compute toxicity probabilities. Can also be
#'   missing for some models.
#' @param model_eff (`ModelEff`)\cr the efficacy model with pseudo data prior.
#' @param samples_eff (`Samples`)\cr samples of model's parameters that will be
#'   used to compute expected efficacy values. Can also be missing for some
#'   models.
#' @param ... not used.
#'
#' @return The gain values.
#'
#' @export
#' @example examples/Model-method-gain.R
#'
setGeneric(
  name = "gain",
  def = function(dose, model_dle, samples_dle, model_eff, samples_eff, ...) {
    standardGeneric("gain")
  },
  valueClass = "numeric"
)

## ModelTox-ModelEff ----

#' @describeIn gain
#'
#' @aliases gain-ModelTox-ModelEff
#' @export
#'
setMethod(
  f = "gain",
  signature = signature(
    dose = "numeric",
    model_dle = "ModelTox",
    samples_dle = "Samples",
    model_eff = "ModelEff",
    samples_eff = "Samples"
  ),
  definition = function(
    dose,
    model_dle,
    samples_dle,
    model_eff,
    samples_eff,
    ...
  ) {
    dle <- prob(dose, model_dle, samples_dle)
    eff <- efficacy(dose, model_eff, samples_eff)
    assert_length(dle, len = length(eff))
    eff / (1 + (dle / (1 - dle)))
  }
)

## ModelTox-ModelEff-noSamples----

#' @describeIn gain Compute the gain value for a given dose level, pseudo DLE
#'   and Efficacy models without DLE and the Efficacy samples.
#'
#' @aliases gain-ModelTox-Effloglog-noSamples
#' @export
#' @example examples/Model-method-gainNoSamples.R
#'
setMethod(
  f = "gain",
  signature = signature(
    dose = "numeric",
    model_dle = "ModelTox",
    samples_dle = "missing",
    model_eff = "Effloglog",
    samples_eff = "missing"
  ),
  definition = function(dose, model_dle, model_eff, ...) {
    dle <- prob(dose, model_dle)
    eff <- efficacy(dose, model_eff)
    assert_length(dle, len = length(eff))
    eff / (1 + (dle / (1 - dle)))
  }
)

# update ----

## ModelPseudo ----

#' Update method for the [`ModelPseudo`] model class. This is a method to update
#' the model class slots (estimates, parameters, variables and etc.), when the
#' new data (e.g. new observations of responses) are available. This method is
#' mostly used to obtain new modal estimates for pseudo model parameters.
#'
#' @param object (`ModelPseudo`)\cr the model to update.
#' @param data (`Data`)\cr all currently available of data.
#' @param ... not used.
#'
#' @return the new [`ModelPseudo`] class object.
#'
#' @aliases update-ModelPseudo
#' @export
#' @example examples/Model-method-update.R
#'
setMethod(
  f = "update",
  signature = signature(
    object = "ModelPseudo"
  ),
  definition = function(object, data, ...) {
    assert_class(data, "Data")

    constructor_name <- class(object)
    arg_names <- setdiff(formalArgs(constructor_name), "data")
    do.call(
      constructor_name,
      c(h_slots(object, arg_names), list(data = data))
    )
  }
)

# tidy ----

# LogisticIndepBeta

#' Tidy Method for the [`LogisticIndepBeta`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`LogisticIndepBeta`] object.
#'
#' @return The [`list`] of [`tibble`] objects.
#'
#' @aliases tidy-LogisticIndepBeta
#' @rdname tidy
#' @method tidy LogisticIndepBeta
#' @export
#' @example examples/LogisticIndepBeta-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "LogisticIndepBeta"),
  definition = function(x, ...) {
    start <- callNextMethod()
    # N$DLEweights Dose$DLEdose Tox$binDLE
    pseudoData <- tibble::tibble(
      Dose = dplyr::pull(start$DLEdose),
      N = dplyr::pull(start$DLEweights),
      Tox = dplyr::pull(start$binDLE)
    )
    params <- tibble::tibble(
      Param = c("Phi1", "Phi2"),
      mean = c(dplyr::pull(start$phi1), dplyr::pull(start$phi2)),
      cov = as.list(start$Pcov)
    )
    list(
      pseudoData = pseudoData,
      data = start$data,
      params = params
    ) %>%
      h_tidy_class(x)
  }
)

# Effloglog

#' Tidy Method for the [`Effloglog`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`Effloglog`] object.
#'
#' @return The [`list`] of [`tibble`] objects.
#'
#' @aliases tidy-Effloglog
#' @rdname tidy
#' @method tidy Edffloglog
#' @export
#' @example examples/Effloglog-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "Effloglog"),
  definition = function(x, ...) {
    start <- callNextMethod()
    pseudoData <- tibble::tibble(
      Dose = dplyr::pull(start$eff_dose),
      Response = dplyr::pull(start$eff)
    )
    params <- tibble::tibble(
      Param = c("theta1", "theta2"),
      mean = c(dplyr::pull(start$theta1), dplyr::pull(start$theta2)),
      cov = as.list(start$Pcov)
    )
    list(
      pseudoData = pseudoData,
      data = start$data,
      params = params
    ) %>%
      h_tidy_class(x)
  }
)

# StoppingOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingOrdinal
knit_print.StoppingOrdinal <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "Based on a toxicity grade of ",
    x@grade,
    ": ",
    paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n")
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMaxGainCIRatio ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMaxGainCIRatio
knit_print.StoppingMaxGainCIRatio <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If the ratio of the upper to the lower limit of the posterior 95% credible ",
    "interval for the probability of toxicity at the target dose (the smaller ",
    "of the MTD for ",
    100 * x@prob_target,
    "% target and GStar) is less than or equal to ",
    x@target_ratio,
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingList ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param preamble (`character`)\cr the text that introduces the list of rules
#' @param indent (`integer`)\cr the indent level of the current stopping rule
#'   list. Spaces with length `indent * 4` will be prepended to the beginning of
#'   the rendered stopping rule list.
#' @rdname knit_print
#' @export
#' @method knit_print StoppingList
knit_print.StoppingList <- function(
  x,
  ...,
  preamble,
  indent = 0L,
  asis = TRUE
) {
  assert_flag(asis)
  assert_integer(indent, lower = 0)

  if (missing(preamble)) {
    case_string <- switch(
      as.character(length(x@stop_list)),
      `1` = "rule ",
      "rules "
    )
    preamble <- paste0(
      "If the result of applying the summary function to the following ",
      case_string,
      "is `TRUE`:\n"
    )
  } else {
    assert_character(preamble, len = 1, any.missing = FALSE)
  }

  rules_list <- paste0(
    lapply(
      x@stop_list,
      function(z, indent) {
        paste0(
          strrep(" ", indent * 4),
          "-  ",
          knit_print(z, asis = FALSE, indent = indent + 1L, ...)
        )
      },
      indent = indent
    ),
    collapse = "\n"
  )
  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    preamble,
    "\n",
    rules_list,
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingAny ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingList
#' @rdname knit_print
#' @export
#' @method knit_print StoppingAny
knit_print.StoppingAny <- function(
  x,
  ...,
  preamble,
  asis = TRUE
) {
  if (missing(preamble)) {
    case_string <- switch(
      as.character(length(x@stop_list)),
      `1` = c("this ", "rule is "),
      `2` = c("either of the ", "rules are "),
      c("any of the ", "rules are ") # this works as default case
    )
    preamble <- paste0(
      "If ",
      case_string[1],
      "following ",
      case_string[2],
      "`TRUE`:\n"
    )
  }
  knit_print.StoppingList(x, ..., preamble = preamble, asis = asis)
}

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingList
#' @rdname knit_print
#' @export
#' @method knit_print StoppingAll
knit_print.StoppingAll <- function(
  x,
  ...,
  preamble,
  asis = TRUE
) {
  if (missing(preamble)) {
    case_string <- switch(
      as.character(length(x@stop_list)),
      `1` = c("this ", "rule is "),
      `2` = c("both of the ", "rules are "),
      c("all of the ", "rules are ") # this works as default case
    )
    preamble <- paste0(
      "If ",
      case_string[1],
      "following ",
      case_string[2],
      "`TRUE`:\n"
    )
  }
  knit_print.StoppingList(x, ..., preamble = preamble, asis = asis)
}

# StoppingTDCIRatio ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingTDCIRatio
knit_print.StoppingTDCIRatio <- function(
  x,
  ...,
  dose_label = "the next best dose",
  tox_label = "toxicity",
  fmt_string = paste0(
    "%sIf, at %s, the ratio of the upper to the lower limit of the posterior ",
    "95%% credible interval for %s (targetting %2.0f%%) is less than or equal to "
  ),
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(fmt_string, len = 1, any.missing = FALSE)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(dose_label, len = 1, any.missing = FALSE)

  rv <- paste0(
    sprintf(
      fmt_string,
      ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
      dose_label,
      tox_label,
      100 * x@prob_target
    ),
    x@target_ratio,
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingTargetBiomarker ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param biomarker_label (`character`)\cr the term used to describe the biomarker
#' @rdname knit_print
#' @export
#' @method knit_print StoppingTargetBiomarker
knit_print.StoppingTargetBiomarker <- function(
  x,
  ...,
  dose_label = "the next best dose",
  biomarker_label = "the target biomarker",
  fmt_string = paste0(
    "%sIf, at %s, the posterior probability that %s is in the range ",
    "(%.2f, %.2f)%s is %.0f%% or more.\n\n"
  ),
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(fmt_string, len = 1, any.missing = FALSE)
  assert_character(biomarker_label, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    dose_label,
    biomarker_label,
    x@target[1],
    x@target[2],
    ifelse(
      x@is_relative,
      paste0(", relative to the maximum value of ", biomarker_label, ","),
      ""
    ),
    100 * x@prob
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingLowestDoseHSRBeta ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingLowestDoseHSRBeta
knit_print.StoppingLowestDoseHSRBeta <- function(
  x,
  ...,
  tox_label = "toxicity",
  fmt_string = paste0(
    "%sIf, using a Hard Stopping Rule with a prior of Beta(%.0f, %.0f), the ",
    "lowest dose in the dose grid has a posterior probability of %s of ",
    "%.0f%% or more.\n\n"
  ),
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(fmt_string, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    x@a,
    x@b,
    tox_label,
    100 * x@prob
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMTDCV ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMTDCV
knit_print.StoppingMTDCV <- function(
  x,
  ...,
  fmt_string = paste0(
    "%sIf the posterior estimate of the robust coefficient of variation of ",
    "the MTD (targetting %2.0f%%), is than or equal to %.0f%%.\n\n"
  ),
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(fmt_string, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    100 * x@target,
    100 * x@thresh_cv
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMTDdistribution ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMTDdistribution
knit_print.StoppingMTDdistribution <- function(
  x,
  ...,
  fmt_string = "%sIf the mean posterior probability of %s at %.0f%% of %s is at least %4.2f.\n\n",
  dose_label = "the next best dose",
  tox_label = "toxicity",
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(dose_label, len = 1, any.missing = FALSE)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(fmt_string, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    tox_label,
    100 * x@thresh,
    dose_label,
    x@prob
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingHighestDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingHighestDose
knit_print.StoppingHighestDose <- function(
  x,
  ...,
  dose_label = "the highest dose in the dose grid",
  asis = TRUE
) {
  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If the next best dose is ",
    dose_label,
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingSpecificDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingSpecificDose
knit_print.StoppingSpecificDose <- function(
  x,
  ...,
  dose_label = as.character(x@dose),
  asis = TRUE
) {
  x@rule@report_label <- x@report_label
  knit_print(
    x@rule,
    ...,
    dose_label = dose_label,
    asis = asis
  )
}

# StoppingTargetProb ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @param fmt_string (`character`)\cr the character string that defines the format
#' of the output
#' @param dose_label (`character`)\cr the term used to describe the target dose
#' @param tox_label (`character`)\cr the term used to describe toxicity
#' @rdname knit_print
#' @export
#' @method knit_print StoppingTargetProb
knit_print.StoppingTargetProb <- function(
  x,
  ...,
  fmt_string = paste0(
    "%sIf the probability of %s at %s is in the range [%4.2f, %4.2f] ",
    "is at least %4.2f.\n\n"
  ),
  dose_label = "the next best dose",
  tox_label = "toxicity",
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(dose_label, len = 1, any.missing = FALSE)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(fmt_string, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    tox_label,
    dose_label,
    x@target[1],
    x@target[2],
    x@prob
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMinCohorts ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMinCohorts
knit_print.StoppingMinCohorts <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If ",
    x@nCohorts,
    " or more cohorts have been treated.\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMinPatients ----

#' @description `r lifecycle::badge("experimental")`
#' @param label (`character`)\cr the term used to label participants
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMinPatients
knit_print.StoppingMinPatients <- function(
  x,
  ...,
  label = "participant",
  asis = TRUE
) {
  assert_flag(asis)
  label <- h_prepare_labels(label)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If ",
    x@nPatients,
    paste0(" or more ", label[2], " have been treated."),
    "\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingPatientsNearDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param label (`character`)\cr the term used to label participants
#' @inheritParams knit_print.StoppingTargetProb
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingPatientsNearDose
knit_print.StoppingPatientsNearDose <- function(
  x,
  ...,
  dose_label = "the next best dose",
  label = "participants",
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(label, len = 1, any.missing = FALSE)
  assert_character(dose_label, len = 1, any.missing = FALSE)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If ",
    x@nPatients,
    paste0(" or more ", label, " have been treated "),
    ifelse(
      x@percentage == 0,
      "at ",
      paste0("within ", x@percentage, "% of ")
    ),
    dose_label,
    ".\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingCohortsNearDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingCohortsNearDose
knit_print.StoppingCohortsNearDose <- function(
  x,
  ...,
  dose_label = "the next best dose",
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(dose_label, len = 1, any.missing = FALSE)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If ",
    x@nCohorts,
    " or more cohorts have been treated ",
    ifelse(
      x@percentage == 0,
      "at ",
      paste0("within ", x@percentage, "% of ")
    ),
    dose_label,
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMissingDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMissingDose
knit_print.StoppingMissingDose <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If the dose returned by <code>nextBest()</code> is ",
    "<code>NA</code>, or if the trial includes a placebo dose, the placebo dose.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @include helpers.R
#' @include helpers_jags.R
#' @include Model-validity.R
#' @include ModelParams-class.R
#' @include CrmPackClass-class.R
NULL

# GeneralModel-class ----

#' `GeneralModel`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`GeneralModel`] is a general model class, from which all other specific
#' model-like classes inherit.
#'
#' @note The `datamodel` must obey the convention that the data input is
#'   called exactly in the same way as in the corresponding data class.
#'   All prior distributions for parameters should be contained in the
#'   model function `priormodel`. The background is that this can
#'   be used to simulate from the prior distribution, before obtaining any data.
#'
#' @slot datamodel (`function`)\cr a function representing the `JAGS` data model
#'   specification.
#' @slot priormodel (`function`)\cr a function representing the `JAGS` prior
#'   specification.
#' @slot modelspecs (`function`)\cr a function computing the list of the data
#'   model and prior model specifications that are required to be specified
#'   completely (e.g. prior parameters, reference dose, etc.), based on the data
#'   slots that are required as arguments of this function.
#'   Apart of data arguments, this function can be specified with one additional
#'   (optional) argument `from_prior` of type `logical` and length one. This
#'   `from_prior` flag can be used to differentiate the output of the `modelspecs`,
#'   as its value is taken directly from the `from_prior` argument of the `mcmc`
#'   method that invokes `modelspecs` function. That is, when `from_prior` is
#'   `TRUE`, then only `priormodel` JAGS model is used (`datamodel` is not used)
#'   by the `mcmc`, and hence `modelspecs` function should return all the parameters
#'   that are required by the `priormodel` only. If the value of `from_prior` is
#'   `FALSE`, then both JAGS models `datamodel` and `priormodel` are used in the
#'   MCMC sampler, and hence `modelspecs` function should return all the parameters
#'   required by both `datamodel` and `priormodel`.
#' @slot init (`function`)\cr a function computing the list of starting values
#'   for parameters required to be initialized in the MCMC sampler, based on the
#'   data slots that are required as arguments of this function.
#' @slot datanames (`character`)\cr the names of all data slots that are used
#'   by `datamodel` JAGS function. No other names should be specified here.
#' @slot datanames_prior (`character`)\cr the names of all data slots that are
#'   used by `priormodel` JAGS function. No other names should be specified here.
#' @slot sample (`character`)\cr names of all parameters from which you would
#'   like to save the MCMC samples.
#'
#' @seealso [`ModelPseudo`].
#'
#' @aliases GeneralModel
#' @export
#'
.GeneralModel <- setClass(
  Class = "GeneralModel",
  slots = c(
    datamodel = "function",
    priormodel = "function",
    modelspecs = "function",
    init = "function",
    datanames = "character",
    datanames_prior = "character",
    sample = "character"
  ),
  prototype = prototype(
    datamodel = I,
    priormodel = I,
    init = function() {
      list()
    }
  ),
  contains = "CrmPackClass",
  validity = v_general_model
)

## default constructor ----

#' @rdname GeneralModel-class
#' @note Typically, end users will not use the `.DefaultGeneralModel()` function.
#' @export
.DefaultGeneralModel <- function() {
  stop(paste0(
    "Class GeneralModel should not be instantiated directly.  Please use one of its subclasses instead."
  ))
}


# ModelLogNormal ----

## class ----

#' `ModelLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelLogNormal`] is the class for a model with a reference dose and bivariate
#' normal prior on the model parameters `alpha0` and natural logarithm of `alpha1`,
#' i.e.: \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov),}. Transformations other
#' than `log`, e.g. identity, can be specified too in `priormodel` slot.
#' The parameter `alpha1` has a log-normal distribution by default to ensure
#' positivity of `alpha1` which further guarantees `exp(alpha1) > 1`.
#' The slots of this class contain the mean vector, the covariance and
#' precision matrices of the bivariate normal distribution, as well as the
#' reference dose. Note that the precision matrix is an inverse of the
#' covariance matrix in the `JAGS`.
#' All ("normal") model specific classes inherit from this class.
#'
#' @slot params (`ModelParamsNormal`)\cr bivariate normal prior parameters.
#' @slot ref_dose (`positive_number`)\cr the reference dose.
#'
#' @seealso [`ModelParamsNormal`], [`LogisticNormal`], [`LogisticLogNormal`],
#'   [`LogisticLogNormalSub`], [`ProbitLogNormal`], [`ProbitLogNormalRel`].
#'
#' @aliases ModelLogNormal
#' @export
#'
.ModelLogNormal <- setClass(
  Class = "ModelLogNormal",
  contains = "GeneralModel",
  slots = c(
    params = "ModelParamsNormal",
    ref_dose = "positive_number"
  )
)

## constructor ----

#' @rdname ModelLogNormal-class
#'
#' @param mean (`numeric`)\cr the prior mean vector.
#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
#'   `prec` is internally calculated as an inverse of `cov`.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*} (strictly positive
#'   number).
#'
#' @export
#'
ModelLogNormal <- function(mean, cov, ref_dose = 1) {
  params <- ModelParamsNormal(mean, cov)
  .ModelLogNormal(
    params = params,
    ref_dose = positive_number(ref_dose),
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      alpha1 <- exp(theta[2])
    },
    modelspecs = function(from_prior) {
      ms <- list(mean = params@mean, prec = params@prec)
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1")
  )
}

## default constructor ----

#' @rdname ModelLogNormal-class
#' @note Typically, end users will not use the `.DefaultModelLogNormal()` function.
#' @export
.DefaultModelLogNormal <- function() {
  ModelLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)
  )
}

# LogisticNormal ----

## class ----

#' `LogisticNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticNormal`] is the class for the usual logistic regression model with
#' a bivariate normal prior on the intercept and slope.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, alpha1) ~ Normal(mean, cov).}
#'
#' @seealso [`ModelLogNormal`], [`LogisticLogNormal`], [`LogisticLogNormalSub`],
#'   [`ProbitLogNormal`], [`ProbitLogNormalRel`], [`LogisticNormalMixture`].
#'
#' @aliases LogisticNormal
#' @export
#'
.LogisticNormal <- setClass(
  Class = "LogisticNormal",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname LogisticNormal-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-LogisticNormal.R
#'
LogisticNormal <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .LogisticNormal(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      alpha1 <- theta[2]
    }
  )
}

## default constructor ----

#' @rdname LogisticNormal-class
#' @note Typically, end users will not use the `.DefaultLogisticNormal()` function.
#' @export
.DefaultLogisticNormal <- function() {
  LogisticNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)
  )
}


# LogisticLogNormal ----

## class ----

#' `LogisticLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticLogNormal`] is the class for the usual logistic regression model
#' with a bivariate normal prior on the intercept and log slope.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormalSub`],
#'   [`ProbitLogNormal`], [`ProbitLogNormalRel`], [`LogisticLogNormalMixture`],
#'   [`DALogisticLogNormal`].
#'
#' @aliases LogisticLogNormal
#' @export
#'
.LogisticLogNormal <- setClass(
  Class = "LogisticLogNormal",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname LogisticLogNormal-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-LogisticLogNormal.R
#'
LogisticLogNormal <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .LogisticLogNormal(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    }
  )
}

## default constructor ----

#' @rdname LogisticLogNormal-class
#' @note Typically, end users will not use the `.DefaultLogisticLogNormal()` function.
#' @export
.DefaultLogisticLogNormal <- function() {
  LogisticLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 50
  )
}

# LogisticLogNormalSub ----

## class ----

#' `LogisticLogNormalSub`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticLogNormalSub`] is the class for a standard logistic model with
#' bivariate (log) normal prior with subtractive dose standardization.
#'
#' @details The covariate is the dose \eqn{x} minus the reference dose \eqn{x*},
#'   i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * (x - x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @slot params (`ModelParamsNormal`)\cr bivariate normal prior parameters.
#' @slot ref_dose (`number`)\cr the reference dose \eqn{x*}.
#'
#' @seealso [`LogisticNormal`], [`LogisticLogNormal`], [`ProbitLogNormal`],
#'   [`ProbitLogNormalRel`].
#'
#' @aliases LogisticLogNormalSub
#' @export
#'
.LogisticLogNormalSub <- setClass(
  Class = "LogisticLogNormalSub",
  slots = c(
    params = "ModelParamsNormal",
    ref_dose = "numeric"
  ),
  contains = "GeneralModel"
)

## constructor ----

#' @rdname LogisticLogNormalSub-class
#'
#' @param mean (`numeric`)\cr the prior mean vector.
#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
#'   `prec` is internally calculated as an inverse of `cov`.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*}.
#'
#' @export
#' @example examples/Model-class-LogisticLogNormalSub.R
#'
LogisticLogNormalSub <- function(mean, cov, ref_dose = 0) {
  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalSub(
    params = params,
    ref_dose = ref_dose,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * (x[i] - ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      alpha1 <- exp(theta[2])
    },
    modelspecs = function(from_prior) {
      ms <- list(mean = params@mean, prec = params@prec)
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, -20))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1")
  )
}


## default constructor ----

#' @rdname LogisticLogNormalSub-class
#' @note Typically, end-users will not use the `.DefaultLogisticLogNormalSub()` function.
#' @export
.DefaultLogisticLogNormalSub <- function() {
  LogisticLogNormalSub(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 50
  )
}

# ProbitLogNormal ----

## class ----

#' `ProbitLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ProbitLogNormal`] is the class for probit regression model with a
#' bivariate normal prior on the intercept and log slope.
#'
#' @details The covariate is the natural logarithm of dose \eqn{x} divided by a
#'   reference dose \eqn{x*}, i.e.:
#'   \deqn{probit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @note This model is also used in the [`DualEndpoint`] classes, so this class
#'   can be used to check the prior assumptions on the dose-toxicity model, even
#'   when sampling from the prior distribution of the dual endpoint model is not
#'   possible.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormal`],
#'   [`LogisticLogNormalSub`], [`ProbitLogNormalRel`].
#'
#' @aliases ProbitLogNormalLogDose
#' @export
#'
.ProbitLogNormal <- setClass(
  Class = "ProbitLogNormal",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname ProbitLogNormal-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-ProbitLogNormal.R
#'
ProbitLogNormal <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .ProbitLogNormal(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        probit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    }
  )
}

## default constructor ----

#' @rdname ProbitLogNormal-class
#' @note Typically, end users will not use the `.DefaultProbitLogNormal()` function.
#' @export
.DefaultProbitLogNormal <- function() {
  ProbitLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 7.2
  )
}

# ProbitLogNormalRel ----

## class ----

#' `ProbitLogNormalRel`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ProbitLogNormalRel`] is the class for probit regression model with a bivariate
#' normal prior on the intercept and log slope.
#'
#' @details The covariate is the dose \eqn{x} divided by a reference dose \eqn{x*},
#'   i.e.:
#'   \deqn{probit[p(x)] = alpha0 + alpha1 * x/x*,}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @note This model is also used in the [`DualEndpoint`] classes, so this class
#'   can be used to check the prior assumptions on the dose-toxicity model, even
#'   when sampling from the prior distribution of the dual endpoint model is not
#'   possible.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormal`],
#'   [`LogisticLogNormalSub`], [`ProbitLogNormal`].
#'
#' @aliases ProbitLogNormalRel
#' @export
#'
.ProbitLogNormalRel <- setClass(
  Class = "ProbitLogNormalRel",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname ProbitLogNormalRel-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-ProbitLogNormalRel.R
#'
ProbitLogNormalRel <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .ProbitLogNormalRel(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        probit(p[i]) <- alpha0 + alpha1 * (x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    }
  )
}

## default constructor ----

#' @rdname ProbitLogNormalRel-class
#' @note Typically, end users will not use the `.DefaultProbitLogNormalRel()` function.
#' @export
.DefaultProbitLogNormalRel <- function() {
  ProbitLogNormalRel(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)
  )
}

# LogisticLogNormalGrouped ----

## class ----

#' `LogisticLogNormalGrouped`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`LogisticLogNormalGrouped`] is the class for a logistic regression model
#'  for both the mono and the combo arms of the simultaneous dose escalation
#'  design.
#'
#' @details The continuous covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*} as in [`LogisticLogNormal`]. In addition,
#'   \eqn{I_c} is a binary indicator covariate which is 1 for the combo arm and 0 for the mono arm.
#'   The model is then defined as:
#'   \deqn{logit[p(x)] = (alpha0 + I_c * delta0) + (alpha1 + I_c * delta1) * log(x / x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x},
#'   and `delta0` and `delta1` are the differences in the combo arm compared to the mono intercept
#'   and slope parameters `alpha0` and `alpha1`.
#'   The prior is defined as \deqn{(alpha0, log(delta0), log(alpha1), log(delta1)) ~ Normal(mean, cov).}
#'
#' @seealso [`ModelLogNormal`], [`LogisticLogNormal`].
#'
#' @aliases LogisticLogNormalGrouped
#' @export
#'
.LogisticLogNormalGrouped <- setClass(
  Class = "LogisticLogNormalGrouped",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname LogisticLogNormalGrouped-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-LogisticLogNormalGrouped.R
#'
LogisticLogNormalGrouped <- function(mean, cov, ref_dose = 1) {
  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalGrouped(
    params = params,
    ref_dose = positive_number(ref_dose),
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      delta0 <- exp(theta[2])
      alpha1 <- exp(theta[3])
      delta1 <- exp(theta[4])
    },
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- (alpha0 + is_combo[i] * delta0) +
          (alpha1 + is_combo[i] * delta1) * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    modelspecs = function(group, from_prior) {
      ms <- list(
        mean = params@mean,
        prec = params@prec
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
        ms$is_combo <- as.integer(group == "combo")
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1, 1, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "delta0", "alpha1", "delta1")
  )
}

## default constructor ----

#' @rdname LogisticLogNormalGrouped-class
#' @note Typically, end users will not use the `.DefaultLogisticLogNormalGrouped()` function.
#' @export
.DefaultLogisticLogNormalGrouped <- function() {
  LogisticLogNormalGrouped(
    mean = rep(0, 4),
    cov = diag(rep(1, 4)),
  )
}

# LogisticKadane ----

## class ----

#' `LogisticKadane`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticKadane`] is the class for the logistic model in the parametrization
#' of Kadane et al. (1980).
#'
#' @details Let `rho0 = p(xmin)` be the probability of a DLT at the minimum dose
#'   `xmin`, and let `gamma` be the dose with target toxicity probability `theta`,
#'   i.e. \eqn{p(gamma) = theta}. Then it can easily be shown that the logistic
#'   regression model has intercept
#'   \deqn{[gamma * logit(rho0) - xmin * logit(theta)] / [gamma - xmin]}
#'   and slope
#'   \deqn{[logit(theta) - logit(rho0)] / [gamma - xmin].}
#'
#'   The priors are \deqn{gamma ~ Unif(xmin, xmax).} and
#'   \deqn{rho0 ~ Unif(0, theta).}
#'
#' @note The slots of this class, required for creating the model, are the target
#'   toxicity, as well as the minimum and maximum of the dose range. Note that
#'   these can be different from the minimum and maximum of the dose grid in the
#'   data later on.
#'
#' @slot theta (`proportion`)\cr the target toxicity probability.
#' @slot xmin (`number`)\cr the minimum of the dose range.
#' @slot xmax (`number`)\cr the maximum of the dose range.
#'
#' @seealso [`ModelLogNormal`]
#'
#' @aliases LogisticKadane
#' @export
#'
.LogisticKadane <- setClass(
  Class = "LogisticKadane",
  contains = "GeneralModel",
  slots = c(
    theta = "numeric",
    xmin = "numeric",
    xmax = "numeric"
  ),
  prototype = prototype(
    theta = 0.3,
    xmin = 0.1,
    xmax = 1
  ),
  validity = v_model_logistic_kadane
)

## constructor ----

#' @rdname LogisticKadane-class
#'
#' @param theta (`proportion`)\cr the target toxicity probability.
#' @param xmin (`number`)\cr the minimum of the dose range.
#' @param xmax (`number`)\cr the maximum of the dose range.
#'
#' @export
#' @example examples/Model-class-LogisticKadane.R
#'
LogisticKadane <- function(theta, xmin, xmax) {
  .LogisticKadane(
    theta = theta,
    xmin = xmin,
    xmax = xmax,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- (1 / (gamma - xmin)) *
          (gamma *
            logit(rho0) -
            xmin * logit(theta) +
            x[i] * (logit(theta) - logit(rho0)))
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      rho0 ~ dunif(0, theta)
      gamma ~ dunif(xmin, xmax)
    },
    modelspecs = function() {
      list(theta = theta, xmin = xmin, xmax = xmax)
    },
    init = function() {
      list(rho0 = theta / 10, gamma = (xmax - xmin) / 2)
    },
    datanames = c("nObs", "y", "x"),
    sample = c("rho0", "gamma")
  )
}

## default constructor ----

#' @rdname LogisticKadane-class
#' @note Typically, end-users will not use the `.DefaultLogisticKadane()` function.
#' @export
.DefaultLogisticKadane <- function() {
  LogisticKadane(theta = 0.33, xmin = 1, xmax = 200)
}


# LogisticKadaneBetaGamma ----

## class ----

#' `LogisticKadaneBetaGamma`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`LogisticKadaneBetaGamma`] is the class for the logistic model in the parametrization
#' of Kadane et al. (1980), using a beta and a gamma distribution as the model priors.
#'
#' @details Let `rho0 = p(xmin)` be the probability of a DLT at the minimum dose
#'   `xmin`, and let `gamma` be the dose with target toxicity probability `theta`,
#'   i.e. \eqn{p(gamma) = theta}. Then it can easily be shown that the logistic
#'   regression model has intercept
#'   \deqn{[gamma * logit(rho0) - xmin * logit(theta)] / [gamma - xmin]}
#'   and slope
#'   \deqn{[logit(theta) - logit(rho0)] / [gamma - xmin].}
#'
#'   The prior for `gamma`, is \deqn{gamma ~ Gamma(shape, rate).}.
#'   The prior for `rho0 = p(xmin)`, is \deqn{rho0 ~ Beta(alpha, beta).}
#'
#' @note The slots of this class, required for creating the model, are the same
#'   as in the `LogisticKadane` class. In addition, the shape parameters of the
#'   Beta prior distribution of `rho0` and the shape and rate parameters of the
#'   Gamma prior distribution of `gamma`, are required for creating the prior model.
#'
#' @slot theta (`proportion`)\cr the target toxicity probability.
#' @slot xmin (`number`)\cr the minimum of the dose range.
#' @slot xmax (`number`)\cr the maximum of the dose range.
#' @slot alpha (`number`)\cr the first shape parameter of the Beta prior distribution
#'   of `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @slot beta (`number`)\cr the second shape parameter of the Beta prior distribution
#'   of `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @slot shape (`number`)\cr the shape parameter of the Gamma prior distribution
#'   of `gamma` the dose with target toxicity probability `theta`.
#' @slot rate (`number`)\cr the rate parameter of the Gamma prior distribution
#'   of `gamma` the dose with target toxicity probability `theta`.
#'
#' @seealso [`ModelLogNormal`], [`LogisticKadane`].
#'
#' @aliases LogisticKadaneBetaGamma
#' @export
#'
.LogisticKadaneBetaGamma <- setClass(
  Class = "LogisticKadaneBetaGamma",
  contains = "LogisticKadane",
  slots = c(
    alpha = "numeric",
    beta = "numeric",
    shape = "numeric",
    rate = "numeric"
  ),
  prototype = prototype(
    theta = 0.3,
    xmin = 0.1,
    xmax = 1,
    alpha = 1,
    beta = 0.5,
    shape = 1.2,
    rate = 2.5
  ),
  validity = v_model_logistic_kadane_beta_gamma
)

## constructor ----

#' @rdname LogisticKadaneBetaGamma-class
#'
#' @inheritParams LogisticKadane
#'
#' @param alpha (`number`)\cr the first shape parameter of the Beta prior distribution
#'   `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @param beta (`number`)\cr the second shape parameter of the Beta prior distribution
#'   `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @param shape (`number`)\cr the shape parameter of the Gamma prior distribution
#'   `gamma` the dose with target toxicity probability `theta`.
#' @param rate (`number`)\cr the rate parameter of the Gamma prior distribution
#'   `gamma` the dose with target toxicity probability `theta`.
#'
#' @export
#' @example examples/Model-class-LogisticKadaneBetaGamma.R
#'
LogisticKadaneBetaGamma <- function(
  theta,
  xmin,
  xmax,
  alpha,
  beta,
  shape,
  rate
) {
  model_lk <- LogisticKadane(theta = theta, xmin = xmin, xmax = xmax)
  .LogisticKadaneBetaGamma(
    model_lk,
    alpha = alpha,
    beta = beta,
    shape = shape,
    rate = rate,
    priormodel = function() {
      rho0 ~ dbeta(alpha, beta)
      gamma ~ dgamma(shape, rate)
      lowestdose <- xmin
      highestdose <- xmax
      DLTtarget <- theta
    },
    modelspecs = function() {
      list(
        theta = theta,
        xmin = xmin,
        xmax = xmax,
        alpha = alpha,
        beta = beta,
        shape = shape,
        rate = rate
      )
    }
  )
}

## default constructor ----

#' @rdname LogisticKadaneBetaGamma-class
#' @note Typically, end users will not use the `.Default()` function.
#' @export
.DefaultLogisticKadaneBetaGamma <- function() {
  LogisticKadaneBetaGamma(
    theta = 0.3,
    xmin = 0,
    xmax = 7,
    alpha = 1,
    beta = 19,
    shape = 0.5625,
    rate = 0.125
  )
}

# LogisticNormalMixture ----

## class ----

#' `LogisticNormalMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticNormalMixture`] is the class for standard logistic regression model
#' with a mixture of two bivariate normal priors on the intercept and slope parameters.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior
#'   \deqn{(alpha0, alpha1) ~ w * Normal(mean1, cov1) + (1 - w) * Normal(mean2, cov2).}
#'   The weight w for the first component is assigned a beta prior `B(a, b)`.
#'
#' @note The weight of the two normal priors is a model parameter, hence it is a
#'   flexible mixture. This type of prior is often used with a mixture of a minimal
#'   informative and an informative component, in order to make the CRM more robust
#'   to data deviations from the informative component.
#'
#' @slot comp1 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the first component.
#' @slot comp2 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the second component.
#' @slot weightpar (`numeric`)\cr the beta parameters for the weight of the
#'   first component. It must a be a named vector of length 2 with names `a` and
#'   `b` and with strictly positive values.
#' @slot ref_dose (`positive_number`)\cr the reference dose.
#'
#' @seealso [`ModelParamsNormal`], [`ModelLogNormal`],
#'   [`LogisticNormalFixedMixture`], [`LogisticLogNormalMixture`].
#'
#' @aliases LogisticNormalMixture
#' @export
#'
.LogisticNormalMixture <- setClass(
  Class = "LogisticNormalMixture",
  contains = "GeneralModel",
  slots = c(
    comp1 = "ModelParamsNormal",
    comp2 = "ModelParamsNormal",
    weightpar = "numeric",
    ref_dose = "numeric"
  ),
  prototype = prototype(
    comp1 = ModelParamsNormal(mean = c(0, 1), cov = diag(2)),
    comp2 = ModelParamsNormal(mean = c(-1, 1), cov = diag(2)),
    weightpar = c(a = 1, b = 1),
    ref_dose = 1
  ),
  validity = v_model_logistic_normal_mix
)

## constructor ----

#' @rdname LogisticNormalMixture-class
#'
#' @param comp1 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the first component. See [`ModelParamsNormal`] for more details.
#' @param comp2 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the second component. See [`ModelParamsNormal`] for more details.
#' @param weightpar (`numeric`)\cr the beta parameters for the weight of the
#'   first component. It must a be a named vector of length 2 with names `a` and
#'   `b` and with strictly positive values.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*}
#'   (strictly positive number).
#'
#' @export
#' @example examples/Model-class-LogisticNormalMixture.R
#'
LogisticNormalMixture <- function(comp1, comp2, weightpar, ref_dose) {
  assert_number(ref_dose)

  .LogisticNormalMixture(
    comp1 = comp1,
    comp2 = comp2,
    weightpar = weightpar,
    ref_dose = ref_dose,
    datamodel = function() {
      # The logistic likelihood - the same as for non-mixture case.
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      w ~ dbeta(weightpar[1], weightpar[2])
      wc <- 1 - w
      comp0 ~ dbern(wc)
      comp <- comp0 + 1
      # Conditional on the component index "comp", which is  1 or 2.
      # comp = 1 with probability "w" and comp = 2 with probability "1 - w".
      theta ~ dmnorm(mean[1:2, comp], prec[1:2, 1:2, comp])
      alpha0 <- theta[1]
      alpha1 <- theta[2]
    },
    modelspecs = function(from_prior) {
      ms <- list(
        mean = cbind(comp1@mean, comp2@mean),
        prec = array(data = c(comp1@prec, comp2@prec), dim = c(2, 2, 2)),
        weightpar = weightpar
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1", "w")
  )
}

## default constructor ----

#' @rdname LogisticNormalMixture-class
#' @note Typically, end-users will not use the `.DefaultLogisticNormalMixture()` function.
#' @export
.DefaultLogisticNormalMixture <- function() {
  # nolint
  LogisticNormalMixture(
    comp1 = ModelParamsNormal(
      mean = c(-0.85, 1),
      cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)
    ),
    comp2 = ModelParamsNormal(
      mean = c(1, 1.5),
      cov = matrix(c(1.2, -0.45, -0.45, 0.6), nrow = 2)
    ),
    weightpar = c(a = 1, b = 1),
    ref_dose = 50
  )
}

# LogisticNormalFixedMixture ----

## class ----

#' `LogisticNormalFixedMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticNormalFixedMixture`] is the class for standard logistic regression
#' model with fixed mixture of multiple bivariate (log) normal priors on the
#' intercept and slope parameters. The weights of the normal priors are fixed,
#' hence no additional model parameters are introduced. This type of prior is
#' often used to better approximate a given posterior distribution, or when the
#' information is given in terms of a mixture.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided
#'   by the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior
#'   \deqn{(alpha0, alpha1) ~ w1 * Normal(mean1, cov1) + ... + wK * Normal(meanK, covK),}
#'   if a normal prior is used and
#'   \deqn{(alpha0, log(alpha1)) ~ w1 * Normal(mean1, cov1) + ... + wK * Normal(meanK, covK),}
#'   if a log normal prior is used.
#'   The weights \eqn{w1, ..., wK} of the components are fixed and sum to 1.
#'
#'   The slots of this class comprise a list with components parameters. Every
#'   single component contains the mean vector and the covariance matrix of
#'   bivariate normal distributions. Remaining slots are the weights of the
#'   components as well as the reference dose. Moreover, a special indicator
#'   slot specifies whether a log normal prior is used.
#'
#' @slot components (`list`)\cr the specifications of the mixture components,
#'   a list with [`ModelParamsNormal`] objects for each bivariate (log) normal
#'   prior.
#' @slot weights (`numeric`)\cr the weights of the components; these must be
#'   positive and must sum to 1.
#' @slot ref_dose (`positive_number`)\cr the reference dose.
#' @slot log_normal (`flag`)\cr should a log normal prior be used, such
#'   that the mean vectors and covariance matrices are valid for the intercept
#'   and log slope?
#'
#' @seealso [`ModelParamsNormal`], [`ModelLogNormal`],
#'   [`LogisticNormalMixture`], [`LogisticLogNormalMixture`].
#'
#' @aliases LogisticNormalFixedMixture
#' @export
#'
.LogisticNormalFixedMixture <- setClass(
  Class = "LogisticNormalFixedMixture",
  contains = "GeneralModel",
  slots = c(
    components = "list",
    weights = "numeric",
    ref_dose = "numeric",
    log_normal = "logical"
  ),
  prototype = prototype(
    components = list(
      comp1 = ModelParamsNormal(mean = c(0, 1), cov = diag(2)),
      comp2 = ModelParamsNormal(mean = c(-1, 1), cov = diag(2))
    ),
    weights = c(0.5, 0.5),
    ref_dose = 1,
    log_normal = FALSE
  ),
  validity = v_model_logistic_normal_fixed_mix
)

## constructor ----

#' @rdname LogisticNormalFixedMixture-class
#'
#' @param components (`list`)\cr the specifications of the mixture components,
#'   a list with [`ModelParamsNormal`] objects for each bivariate (log) normal
#'   prior.
#' @param weights (`numeric`)\cr the weights of the components; these must be
#'   positive and will be normalized to sum to 1.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*}
#'   (strictly positive number).
#' @param log_normal (`flag`)\cr should a log normal prior be specified, such
#'   that the mean vectors and covariance matrices are valid for the intercept
#'   and log slope?
#'
#' @export
#' @example examples/Model-class-LogisticNormalFixedMixture.R
#'
LogisticNormalFixedMixture <- function(
  components,
  weights,
  ref_dose,
  log_normal = FALSE
) {
  assert_numeric(weights)
  assert_number(ref_dose)
  assert_flag(log_normal)

  # Normalize weights to sum to 1.
  weights <- weights / sum(weights)

  .LogisticNormalFixedMixture(
    components = components,
    weights = weights,
    ref_dose = positive_number(ref_dose),
    log_normal = log_normal,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = if (log_normal) {
      function() {
        comp ~ dcat(weights)
        theta ~ dmnorm(mean[1:2, comp], prec[1:2, 1:2, comp])
        alpha0 <- theta[1]
        alpha1 <- exp(theta[2])
      }
    } else {
      function() {
        comp ~ dcat(weights)
        theta ~ dmnorm(mean[1:2, comp], prec[1:2, 1:2, comp])
        alpha0 <- theta[1]
        alpha1 <- theta[2]
      }
    },
    modelspecs = function(from_prior) {
      ms <- list(
        weights = weights,
        mean = do.call(
          cbind,
          lapply(components, h_slots, "mean", simplify = TRUE)
        ),
        prec = array(
          do.call(c, lapply(components, h_slots, "prec", simplify = TRUE)),
          dim = c(2, 2, length(components))
        )
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1")
  )
}

## default constructor ----

#' @rdname LogisticNormalFixedMixture-class
#' @note Typically, end-users will not use the `.DefaultLogisticNormalFixedMixture()`
#' function.
#' @export
.DefaultLogisticNormalFixedMixture <- function() {
  # nolint
  LogisticNormalFixedMixture(
    components = list(
      comp1 = ModelParamsNormal(
        mean = c(-0.85, 1),
        cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)
      ),
      comp2 = ModelParamsNormal(
        mean = c(1, 1.5),
        cov = matrix(c(1.2, -0.45, -0.45, 0.6), nrow = 2)
      )
    ),
    weights = c(0.3, 0.7),
    ref_dose = 50
  )
}

# LogisticLogNormalMixture ----

## class ----

#' `LogisticLogNormalMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticLogNormalMixture`] is the class for standard logistic model with
#' online mixture of two bivariate log normal priors.
#'
#' @details This model can be used when data is arising online from the informative
#'   component of the prior, at the same time with the data of the trial of
#'   main interest. Formally, this is achieved by assuming that the probability
#'   of a DLT at dose \eqn{x} is given by
#'   \deqn{p(x) = \pi * p1(x) + (1 - \pi) * p2(x)}
#'   where \eqn{\pi} is the probability for the model \eqn{p(x)} being the same
#'   as the model \eqn{p1(x)}, which is the informative component of the prior.
#'   From this model data arises in parallel: at doses `xshare`, DLT information
#'   `yshare` is observed, in total `nObsshare` data points (see [`DataMixture`]).
#'   On the other hand, \eqn{1 - \pi}, is the probability of a separate model
#'   \eqn{p2(x)}. Both components have the same log normal prior distribution,
#'   which can be specified by the user, and which is inherited from the
#'   [`LogisticLogNormal`] class.
#'
#' @slot share_weight (`proportion`)\cr the prior weight for the share component
#'   \eqn{p_{1}(x)}.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormalMixture`],
#'   [`LogisticNormalFixedMixture`].
#'
#' @aliases LogisticLogNormalMixture
#' @export
#'
.LogisticLogNormalMixture <- setClass(
  Class = "LogisticLogNormalMixture",
  contains = "LogisticLogNormal",
  slots = c(
    share_weight = "numeric"
  ),
  prototype = prototype(
    share_weight = 0.1
  ),
  validity = v_model_logistic_log_normal_mix
)

## constructor ----

#' @rdname LogisticLogNormalMixture-class
#'
#' @inheritParams ModelLogNormal
#' @param share_weight (`proportion`)\cr the prior weight for the share component.
#'
#' @export
#' @example examples/Model-class-LogisticLogNormalMixture.R
#'
LogisticLogNormalMixture <- function(mean, cov, ref_dose, share_weight) {
  assert_number(ref_dose)

  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalMixture(
    params = params,
    ref_dose = positive_number(ref_dose),
    share_weight = share_weight,
    datamodel = function() {
      for (i in 1:nObs) {
        # comp gives the component: non-informative (1) or share (2) the two components.
        stand_log_dose[i] <- log(x[i] / ref_dose)
        logit(p[i]) <- alpha0[comp] + alpha1[comp] * stand_log_dose[i]
        y[i] ~ dbern(p[i])
      }
      for (j in 1:nObsshare) {
        stand_log_dose_share[j] <- log(xshare[j] / ref_dose)
        logit(pshare[j]) <- alpha0[2] + alpha1[2] * stand_log_dose_share[j]
        yshare[j] ~ dbern(pshare[j])
      }
    },
    priormodel = function() {
      for (k in 1:2) {
        theta[k, 1:2] ~ dmnorm(mean, prec)
        alpha0[k] <- theta[k, 1]
        alpha1[k] <- exp(theta[k, 2])
      }
      # The component indicator.
      comp ~ dcat(cat_probs)
    },
    modelspecs = function(from_prior) {
      ms <- list(
        cat_probs = c(1 - share_weight, share_weight),
        mean = params@mean,
        prec = params@prec
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = matrix(c(0, 0, 1, 1), nrow = 2))
    },
    datanames = c("nObs", "y", "x", "nObsshare", "yshare", "xshare"),
    sample = c("alpha0", "alpha1", "comp")
  )
}

## default constructor ----

#' @rdname LogisticLogNormalMixture-class
#' @note Typically, end users will not use the `.DefaultLogNormalMixture()` function.
#' @export
.DefaultLogisticLogNormalMixture <- function() {
  # nolint
  LogisticLogNormalMixture(
    share_weight = 0.1,
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 50
  )
}

# DualEndpoint ----

## class ----

#' `DualEndpoint`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpoint`] is the general class for the dual endpoint model.
#'
#' @details The idea of the dual-endpoint models is to model not only the
#'   dose-toxicity relationship, but also to model, at the same time, the
#'   relationship of a PD biomarker with the dose. The sub-classes of this class
#'   define how the dose-biomarker relationship is parametrized. This class here
#'   shall contain all the common features to reduce duplicate code.
#'   (This class however, must not be virtual as we need to create objects
#'   of it during the construction of subclass objects.)
#'
#'   The dose-toxicity relationship is modeled with probit regression model
#'   \deqn{probit[p(x)] = betaZ1 + betaZ2 * x/x*,}
#'   or
#'   \deqn{probit[p(x)] = betaZ1 + betaZ2 * log(x/x*),}
#'   in case when the option `use_log_dose` is `TRUE`.
#'   Here, \eqn{p(x)} is the probability of observing a DLT for a given
#'   dose \eqn{x} and \eqn{x*} is the reference dose.
#'   The prior \deqn{(betaZ1, log(betaZ2)) ~ Normal(mean, cov).}
#'
#'   For the biomarker response \eqn{w} at a dose \eqn{x}, we assume
#'   \deqn{w(x) ~ Normal(f(x), sigma2W),}
#'   where \eqn{f(x)} is a function of the dose \eqn{x}, which is further
#'   specified in sub-classes. The biomarker variance \eqn{sigma2W} can be fixed
#'   or assigned an Inverse-Gamma prior distribution; see the details below under
#'   slot `sigma2W`.
#'
#'   Finally, the two endpoints \eqn{y} (the binary DLT variable) and \eqn{w}
#'   (the biomarker) can be correlated, by assuming a correlation of level
#'   \eqn{rho} between the underlying continuous latent toxicity variable \eqn{z}
#'   and the biomarker \eqn{w}. Again, this correlation can be fixed or assigned
#'   a prior distribution from the scaled Beta family; see the details below
#'   under slot `rho`.
#'
#'   Please see the example vignette by typing `crmPackExample()` for a full example.
#'
#' @slot betaZ_params (`ModelParamsNormal`)\cr for the probit toxicity model, it
#'   contains the prior mean, covariance matrix and precision matrix which is
#'   internally calculated as an inverse of the covariance matrix.
#' @slot ref_dose (`positive_number`)\cr for the probit toxicity model, the
#'   reference dose.
#' @slot use_log_dose (`flag`)\cr for the probit toxicity model, whether a log
#'   transformation of the (standardized) dose should be used?
#' @slot sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
#'   Inverse-Gamma distribution parameters, i.e. vector with two elements named
#'   `a` and `b`.
#' @slot rho (`numeric`)\cr either a fixed value for the correlation
#'   (between `-1` and `1`), or a named vector with two elements named `a` and `b`
#'   for the Beta prior on the transformation `kappa = (rho + 1) / 2`, which is
#'   in `(0, 1)`. For example, `a = 1, b = 1` leads to a uniform prior on `rho`.
#' @slot use_fixed (`logical`)\cr indicates whether a fixed value for `sigma2W`
#'   or `rho` (for each parameter separately) is used or not. This slot is
#'   needed for internal purposes and must not be touched by the user.
#'
#' @seealso [`DualEndpointRW`], [`DualEndpointBeta`], [`DualEndpointEmax`].
#'
#' @aliases DualEndpoint
#' @export
#'
.DualEndpoint <- setClass(
  Class = "DualEndpoint",
  slots = c(
    betaZ_params = "ModelParamsNormal",
    ref_dose = "positive_number",
    use_log_dose = "logical",
    sigma2W = "numeric",
    rho = "numeric",
    use_fixed = "logical"
  ),
  prototype = prototype(
    betaZ_params = ModelParamsNormal(mean = c(0, 1), cov = diag(2)),
    ref_dose = positive_number(1),
    use_log_dose = FALSE,
    sigma2W = 1,
    rho = 0,
    use_fixed = c(sigma2W = TRUE, rho = TRUE)
  ),
  contains = "GeneralModel",
  validity = v_model_dual_endpoint
)

## constructor ----

#' @rdname DualEndpoint-class
#'
#' @param mean (`numeric`)\cr for the probit toxicity model, the prior mean vector.
#' @param cov (`matrix`)\cr for the probit toxicity model, the prior covariance
#'   matrix. The precision matrix is internally calculated as an inverse of `cov`.
#' @param ref_dose (`number`)\cr for the probit toxicity model, the reference
#'   dose \eqn{x*} (strictly positive number).
#' @param use_log_dose (`flag`)\cr for the probit toxicity model, whether a log
#'   transformation of the (standardized) dose should be used?
#' @param sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
#'   Inverse-Gamma distribution parameters, i.e. vector with two elements named
#'   `a` and `b`.
#' @param rho (`numeric`)\cr either a fixed value for the correlation
#'   (between `-1` and `1`), or a named vector with two elements named `a` and `b`
#'   for the Beta prior on the transformation `kappa = (rho + 1) / 2`, which is
#'   in `(0, 1)`. For example, `a = 1, b = 1` leads to a uniform prior on `rho`.
#'
#' @export
#'
DualEndpoint <- function(
  mean,
  cov,
  ref_dose = 1,
  use_log_dose = FALSE,
  sigma2W,
  rho
) {
  assert_number(ref_dose)
  assert_numeric(sigma2W, min.len = 1, max.len = 2)
  assert_numeric(rho, min.len = 1, max.len = 2)

  use_fixed <- c(
    sigma2W = test_number(sigma2W),
    rho = test_number(rho)
  )
  beta_z_params <- ModelParamsNormal(mean, cov)

  datamodel <- function() {
    for (i in 1:nObs) {
      # The toxicity model.
      stand_dose_temp[i] <- x[i] / ref_dose
      stand_dose[i] <- ifelse(
        use_log_dose,
        log(stand_dose_temp[i]),
        stand_dose_temp[i]
      )
      meanZ[i] <- betaZ[1] + betaZ[2] * stand_dose[i]
      z[i] ~ dnorm(meanZ[i], 1)
      y[i] ~ dinterval(z[i], 0)

      # The conditional biomarker model; betaW defined in subclasses!
      condMeanW[i] <- betaW[xLevel[i]] + rho / sqrt(precW) * (z[i] - meanZ[i])
      w[i] ~ dnorm(condMeanW[i], condPrecW)
    }
  }
  priormodel <- function() {
    # Priors for betaW defined in subclasses!
    theta ~ dmnorm(betaZ_mean, betaZ_prec)
    betaZ[1] <- theta[1]
    betaZ[2] <- exp(theta[2])
    # Conditional precision for biomarker.
    # Code for `precW` and `rho` will be added by
    # `h_model_dual_endpoint_sigma2W()`, `h_model_dual_endpoint_rho()` helpers, below.
    condPrecW <- precW / (1 - pow(rho, 2))
  }
  modelspecs_prior <- list(
    betaZ_mean = beta_z_params@mean,
    betaZ_prec = beta_z_params@prec
  )

  comp <- list(
    priormodel = priormodel,
    modelspecs = modelspecs_prior,
    init = NULL,
    sample = "betaZ"
  )

  # Update model components with regard to biomarker regression variance.
  comp <- h_model_dual_endpoint_sigma2W(
    use_fixed["sigma2W"],
    sigma2W = sigma2W,
    comp = comp
  )

  # Update model components with regard to DLT and biomarker correlation.
  comp <- h_model_dual_endpoint_rho(
    use_fixed["rho"],
    rho = rho,
    comp = comp
  )

  .DualEndpoint(
    betaZ_params = beta_z_params,
    ref_dose = positive_number(ref_dose),
    use_log_dose = use_log_dose,
    sigma2W = sigma2W,
    rho = rho,
    use_fixed = use_fixed,
    datamodel = datamodel,
    priormodel = comp$priormodel,
    modelspecs = function(from_prior) {
      if (!from_prior) {
        comp$modelspecs$ref_dose <- ref_dose
        comp$modelspecs$use_log_dose <- use_log_dose
      }
      comp$modelspecs
    },
    init = function(y) {
      c(comp$init, list(z = ifelse(y == 0, -1, 1), theta = c(0, 1)))
    },
    datanames = c("nObs", "w", "x", "xLevel", "y"),
    sample = comp$sample
  )
}

## default constructor ----

#' @rdname DualEndpoint-class
#' @note Typically, end users will not use the `.DefaultDualEndpoint()` function.
#' @export
.DefaultDualEndpoint <- function() {
  stop(paste0(
    "Class DualEndpoint cannot be instantiated directly.  Please use one of its subclasses instead."
  ))
}

# DualEndpointRW ----

## class ----

#' `DualEndpointRW`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpointRW`] is the class for the dual endpoint model with random walk
#' prior for biomarker.
#'
#'
#' @details This class extends the [`DualEndpoint`] class so that the dose-biomarker
#'   relationship \eqn{f(x)} is modelled by a non-parametric random walk of first
#'   or second order. That means, for the first order random walk we assume
#'   \deqn{betaW_i - betaW_i-1 ~ Normal(0, (x_i - x_i-1) * sigma2betaW),}
#'   where \eqn{betaW_i = f(x_i)} is the biomarker mean at the \eqn{i}-th dose
#'   gridpoint \eqn{x_i}.
#'   For the second order random walk, the second-order differences instead of
#'   the first-order differences of the biomarker means follow the normal distribution
#'   with \eqn{0} mean and \eqn{2 * (x_i - x_i-2) * sigma2betaW} variance.
#'
#'   The variance parameter \eqn{sigma2betaW} is important because it steers the
#'   smoothness of the function \eqn{f(x)}, i.e.: if it is large, then \eqn{f(x)}
#'   will be very wiggly; if it is small, then \eqn{f(x)} will be smooth.
#'   This parameter can either be a fixed value or assigned an inverse gamma prior
#'   distribution.
#'
#' @note Non-equidistant dose grids can be used now, because the difference
#'   \eqn{x_i - x_i-1} is included in the modelling assumption above.
#'   Please note that due to impropriety of the random walk prior distributions,
#'   it is not possible to produce MCMC samples with empty data objects (i.e.,
#'   sample from the prior). This is not a bug, but a theoretical feature of this
#'   model.
#'
#' @slot sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
#'   prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
#'   parameters, i.e. vector with two elements named `a` and `b`.
#' @slot rw1 (`flag`)\cr for specifying the random walk prior on the biomarker
#'   level. When `TRUE`, random walk of first order is used. Otherwise, the
#'   random walk of second order is used.
#'
#' @seealso [`DualEndpoint`], [`DualEndpointBeta`], [`DualEndpointEmax`].
#'
#' @aliases DualEndpointRW
#' @export
#'
.DualEndpointRW <- setClass(
  Class = "DualEndpointRW",
  slots = c(
    sigma2betaW = "numeric",
    rw1 = "logical"
  ),
  prototype = prototype(
    sigma2betaW = 1,
    rw1 = TRUE,
    use_fixed = c(
      sigma2W = TRUE,
      rho = TRUE,
      sigma2betaW = TRUE
    )
  ),
  contains = "DualEndpoint",
  validity = v_model_dual_endpoint_rw
)

## constructor ----

#' @rdname DualEndpointRW-class
#'
#' @param sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
#'   prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
#'   parameters, i.e. vector with two elements named `a` and `b`.
#' @param rw1 (`flag`)\cr for specifying the random walk prior on the biomarker
#'   level. When `TRUE`, random walk of first order is used. Otherwise, the
#'   random walk of second order is used.
#' @param ... parameters passed to [DualEndpoint()].
#'
#' @export
#' @example examples/Model-class-DualEndpointRW.R
#'
DualEndpointRW <- function(sigma2betaW, rw1 = TRUE, ...) {
  assert_numeric(sigma2betaW, min.len = 1, max.len = 2)
  assert_flag(rw1)

  start <- DualEndpoint(...)
  start@use_fixed["sigma2betaW"] <- length(sigma2betaW) == 1L

  priormodel <- if (rw1) {
    function() {
      # The 1st order differences.
      # Essentially dflat(), which is not available in JAGS.
      betaW[1] ~ dnorm(0, 0.000001)
      for (i in 2:nGrid) {
        delta[i - 1] ~ dnorm(0, precBetaW / (doseGrid[i] - doseGrid[i - 1]))
        betaW[i] <- betaW[i - 1] + delta[i - 1]
      }
    }
  } else {
    function() {
      # The 2nd order differences.
      delta[1] ~ dnorm(0, 0.000001)
      betaW[1] ~ dnorm(0, 0.000001)
      betaW[2] <- betaW[1] + delta[1]
      for (i in 3:nGrid) {
        # delta2: differences of the differences of betaW follow normal dist.
        delta2[i - 2] ~
          dnorm(0, 2 * precBetaW / (doseGrid[i] - doseGrid[i - 2]))
        delta[i - 1] <- delta[i - 2] + delta2[i - 2]
        betaW[i] <- betaW[i - 1] + delta[i - 1]
      }
    }
  }
  start@priormodel <- h_jags_join_models(start@priormodel, priormodel)
  start@datanames_prior <- c("nGrid", "doseGrid")
  start@sample <- c(start@sample, "betaW", "delta")

  # Update model components with regard to biomarker regression variance.
  start <- h_model_dual_endpoint_sigma2betaW(
    start@use_fixed["sigma2betaW"],
    sigma2betaW = sigma2betaW,
    de = start
  )

  .DualEndpointRW(
    start,
    sigma2betaW = sigma2betaW,
    rw1 = rw1
  )
}

## default constructor ----

#' @rdname DualEndpointRW-class
#' @note Typically, end users will not use the `.DefaultDualEndpointRW()` function.
#' @export
.DefaultDualEndpointRW <- function() {
  DualEndpointRW(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    sigma2betaW = 0.01,
    rw1 = TRUE
  )
}

# DualEndpointBeta ----

## class ----

#' `DualEndpointBeta`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpointBeta`] is the class for the dual endpoint model with beta
#' function for dose-biomarker relationship.
#'
#' @details This class extends the [`DualEndpoint`] class so that the dose-biomarker
#'   relationship \eqn{f(x)} is modelled by a parametric, rescaled beta density
#'   function:
#'   \deqn{f(x) = E0 + (Emax - E0) * Beta(delta1, delta2) * (x/x*)^{delta1} * (1 - x/x*)^{delta2},}
#'   where \eqn{x*} is the maximum dose (end of the dose range to be considered),
#'   \eqn{delta1} and \eqn{delta2} are the two beta function parameters, and
#'   \eqn{E0}, \eqn{Emax} are the minimum and maximum levels, respectively.
#'   For ease of interpretation, we use the parametrization based on \eqn{delta1}
#'   and the mode, where
#'   \deqn{mode = delta1 / (delta1 + delta2),}
#'   so that multiplying this by \eqn{x*} gives the mode on the dose grid.
#'
#'   All parameters can currently be assigned uniform distributions or be fixed
#'   in advance. Note that \code{E0} and \code{Emax} can have negative values or
#'   uniform distributions reaching into negative range, while \code{delta1} and
#'   \code{mode} must be positive or have uniform distributions in the positive
#'   range.
#'
#' @slot E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @slot Emax (`numeric`)\cr either a fixed number or the two uniform
#'   distribution parameters.
#' @slot delta1 (`numeric`)\cr either a fixed positive number or the two
#'   parameters of the uniform distribution, that can take only positive values.
#' @slot mode (`numeric`)\cr either a fixed positive number or the two
#'   parameters of the uniform distribution, that can take only positive values.
#' @slot ref_dose_beta (`positive_number`)\cr the reference dose \eqn{x*} (note
#'   that this is different from the `ref_dose` in the inherited [`DualEndpoint`]
#'   model).
#'
#' @seealso [`DualEndpoint`], [`DualEndpointRW`], [`DualEndpointEmax`].
#'
#' @aliases DualEndpointBeta
#' @export
#'
.DualEndpointBeta <- setClass(
  Class = "DualEndpointBeta",
  slots = c(
    E0 = "numeric",
    Emax = "numeric",
    delta1 = "numeric",
    mode = "numeric",
    ref_dose_beta = "positive_number"
  ),
  prototype = prototype(
    E0 = c(0, 100),
    Emax = c(0, 500),
    delta1 = c(0, 5),
    mode = c(1, 15),
    ref_dose_beta = positive_number(1),
    use_fixed = c(
      sigma2W = TRUE,
      rho = TRUE,
      E0 = FALSE,
      Emax = FALSE,
      delta1 = FALSE,
      mode = FALSE
    )
  ),
  contains = "DualEndpoint",
  validity = v_model_dual_endpoint_beta
)

## constructor ----

#' @rdname DualEndpointBeta-class
#'
#' @param E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param Emax (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param delta1 (`numeric`)\cr either a fixed positive number or the two parameters
#'   of the uniform distribution, that can take only positive values.
#' @param mode (`numeric`)\cr either a fixed positive number or the two parameters
#'   of the uniform distribution, that can take only positive values.
#' @param ref_dose_beta (`number`)\cr the reference dose \eqn{x*} (strictly
#'   positive number). Note that this is different from the `ref_dose` in the
#'   inherited [`DualEndpoint`] model).
#' @param ... parameters passed to [DualEndpoint()].
#'
#' @export
#' @example examples/Model-class-DualEndpointBeta.R
#'
DualEndpointBeta <- function(E0, Emax, delta1, mode, ref_dose_beta = 1, ...) {
  assert_numeric(E0, min.len = 1, max.len = 2)
  assert_numeric(Emax, min.len = 1, max.len = 2)
  assert_numeric(delta1, min.len = 1, max.len = 2)
  assert_numeric(mode, min.len = 1, max.len = 2)
  assert_number(ref_dose_beta)

  start <- DualEndpoint(...)

  ms <- start@modelspecs
  start@modelspecs <- function(from_prior) {
    c(list(ref_dose_beta = ref_dose_beta), ms(from_prior))
  }
  start@datanames_prior <- c("nGrid", "doseGrid")
  start@sample <- c(start@sample, "betaW")

  start <- h_model_dual_endpoint_beta(
    param = E0,
    param_name = "E0",
    priormodel = function() {
      E0 ~ dunif(E0_low, E0_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = Emax,
    param_name = "Emax",
    priormodel = function() {
      Emax ~ dunif(Emax_low, Emax_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = delta1,
    param_name = "delta1",
    priormodel = function() {
      delta1 ~ dunif(delta1_low, delta1_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = mode,
    param_name = "mode",
    priormodel = function() {
      mode ~ dunif(mode_low, mode_high)
    },
    de = start
  )

  start@priormodel <- h_jags_join_models(
    start@priormodel,
    function() {
      # delta2 <- delta1 * (1 - (mode/ref_dose_beta)) / (mode/ref_dose_beta) # nolint
      delta2 <- delta1 * (ref_dose_beta / mode - 1)
      # betafun <- (delta1 + delta2)^(delta1 + delta2) * delta1^(- delta1) * delta2^(- delta2) # nolint
      betafun <- (1 + delta2 / delta1)^delta1 * (delta1 / delta2 + 1)^delta2
      for (i in 1:nGrid) {
        stand_dose_beta[i] <- doseGrid[i] / ref_dose_beta
        betaW[i] <- E0 +
          (Emax - E0) *
            betafun *
            stand_dose_beta[i]^delta1 *
            (1 - stand_dose_beta[i])^delta2
      }
    }
  )

  .DualEndpointBeta(
    start,
    E0 = E0,
    Emax = Emax,
    delta1 = delta1,
    mode = mode,
    ref_dose_beta = positive_number(ref_dose_beta)
  )
}

## default constructor ----

#' @rdname DualEndpointBeta-class
#' @note Typically, end users will not use the `.DefaultDualEndpointBeta()` function.
#' @export
.DefaultDualEndpointBeta <- function() {
  DualEndpointBeta(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    ref_dose = 10,
    use_log_dose = TRUE,
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    E0 = c(0, 100),
    Emax = c(0, 500),
    delta1 = c(0, 5),
    mode = c(1, 15),
    ref_dose_beta = 1000
  )
}

# DualEndpointEmax ----

## class ----

#' `DualEndpointEmax`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpointEmax`] is the class for the dual endpoint model with `Emax`
#' function for dose-biomarker relationship.
#'
#' @details This class extends the [`DualEndpoint`] class so that the dose-biomarker
#'   relationship \eqn{f(x)} is modelled by a parametric `Emax` function:
#'   \deqn{f(x) = E0 + [(Emax - E0) * (x/x*)]/[ED50 + (x/x*)],}
#'   where \eqn{x*} is a reference dose, \eqn{E0} and \eqn{Emax} are the minimum
#'   and maximum levels for the biomarker, and \eqn{ED50} is the dose achieving
#'   half of the maximum effect \eqn{0.5 * Emax}.
#'   All parameters can currently be assigned uniform distributions or be fixed.
#'
#' @slot E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @slot Emax (`numeric`)\cr either a fixed number or the two uniform
#'   distribution parameters.
#' @slot ED50 (`numeric`)\cr either a fixed number or the two uniform
#'   distribution parameters.
#' @slot ref_dose_emax (`positive_number`)\cr the reference dose \eqn{x*} (note
#'   that this is different from the `ref_dose` in the inherited [`DualEndpoint`]
#'   model).
#'
#' @seealso [`DualEndpoint`], [`DualEndpointRW`], [`DualEndpointBeta`].
#'
#' @aliases DualEndpointEmax
#' @export
#'
.DualEndpointEmax <- setClass(
  Class = "DualEndpointEmax",
  slots = c(
    E0 = "numeric",
    Emax = "numeric",
    ED50 = "numeric",
    ref_dose_emax = "numeric"
  ),
  prototype = prototype(
    E0 = c(0, 100),
    Emax = c(0, 500),
    ED50 = c(0, 500),
    ref_dose_emax = positive_number(1),
    use_fixed = c(
      sigma2W = TRUE,
      rho = TRUE,
      E0 = FALSE,
      Emax = FALSE,
      ED50 = FALSE
    )
  ),
  contains = "DualEndpoint",
  validity = v_model_dual_endpoint_emax
)

## constructor ----

#' @rdname DualEndpointEmax-class
#'
#' @param E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param Emax (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param ED50 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param ref_dose_emax (`number`)\cr the reference dose \eqn{x*} (strictly
#'   positive number). Note that this is different from the `ref_dose` in the
#'   inherited [`DualEndpoint`] model).
#' @param ... parameters passed to [DualEndpoint()].
#'
#' @export
#' @example examples/Model-class-DualEndpointEmax.R
#'
DualEndpointEmax <- function(E0, Emax, ED50, ref_dose_emax = 1, ...) {
  assert_numeric(E0, min.len = 1, max.len = 2)
  assert_numeric(Emax, min.len = 1, max.len = 2)
  assert_numeric(ED50, min.len = 1, max.len = 2)
  assert_number(ref_dose_emax)

  start <- DualEndpoint(...)

  start@sample <- c(start@sample, "betaW")
  start@datanames_prior <- c("nGrid", "doseGrid")
  ms <- start@modelspecs
  start@modelspecs <- function(from_prior) {
    c(list(ref_dose_emax = ref_dose_emax), ms(from_prior))
  }

  start <- h_model_dual_endpoint_beta(
    param = E0,
    param_name = "E0",
    priormodel = function() {
      E0 ~ dunif(E0_low, E0_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = Emax,
    param_name = "Emax",
    priormodel = function() {
      Emax ~ dunif(Emax_low, Emax_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = ED50,
    param_name = "ED50",
    priormodel = function() {
      ED50 ~ dunif(ED50_low, ED50_high)
    },
    de = start
  )

  start@priormodel <- h_jags_join_models(
    start@priormodel,
    function() {
      for (i in 1:nGrid) {
        stand_dose_emax[i] <- doseGrid[i] / ref_dose_emax
        betaW[i] <- E0 +
          (Emax - E0) * stand_dose_emax[i] / (ED50 + stand_dose_emax[i])
      }
    }
  )

  .DualEndpointEmax(
    start,
    E0 = E0,
    Emax = Emax,
    ED50 = ED50,
    ref_dose_emax = positive_number(ref_dose_emax)
  )
}

## default constructor ----

#' @rdname DualEndpointEmax-class
#' @note Typically, end users will not use the `.DefaultDualEndpointEmax()` function.
#' @export
.DefaultDualEndpointEmax <- function() {
  DualEndpointEmax(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    E0 = c(0, 100),
    Emax = c(0, 500),
    ED50 = c(10, 200),
    ref_dose_emax = 1000
  )
}

# ModelPseudo ----

## class ----

#' `ModelPseudo`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelPseudo`] is the parent class for models that express their prior in
#' the form of pseudo data (as if there is some data before the trial starts).
#'
#' @seealso [`GeneralModel`].
#'
#' @aliases ModelPseudo
#' @export
#'
.ModelPseudo <- setClass(
  Class = "ModelPseudo",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname ModelPseudo-class
#' @note Typically, end users will not use the `.DefaultModelPseudo()` function.
#' @export
.DefaultModelPseudo <- function() {
  stop(paste0(
    "Class ModelPseudo should not be instantiated directly.  Please use one of its subclasses instead."
  ))
}

# ModelTox ----

## class ----

#' `ModelTox`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelTox`] is the parent class for DLE (dose-limiting events) models using
#' pseudo data prior. It is dedicated for DLE models or toxicity models that
#' have their prior specified in the form of pseudo data (as if there is some
#' data before the trial starts).
#'
#' The `data` must obey the convention of the [`Data`] class. This refers to any
#' observed DLE responses (`y` in [`Data`]), the dose levels (`x` in [`Data`])
#' at which these responses are observed, all dose levels considered in the
#' study (`doseGrid` in [`Data`]), and finally other specifications in [`Data`]
#' class that can be used to generate prior or posterior modal estimates or
#' samples estimates for model parameter(s).
#' If no responses are observed, at least `doseGrid` has to be specified
#' in `data` for which prior modal estimates or samples can be obtained for
#' model parameters based on the specified pseudo data.
#'
#' @slot data (`Data`)\cr observed data that is used to obtain model parameters
#'   estimates or samples (see details above).
#'
#' @seealso [`ModelEff`].
#'
#' @aliases ModelTox
#' @export
#'
.ModelTox <- setClass(
  Class = "ModelTox",
  slots = c(
    data = "Data"
  ),
  contains = "ModelPseudo"
)

## default constructor ----

#' @rdname ModelTox-class
#' @note Typically, end users will not use the `.DefaultModelTox()` function.
#' @export
.DefaultModelTox <- function() {
  stop(paste0(
    "Class ModelTox should not be instantiated directly.  Please use one of its subclasses instead."
  ))
}

# ModelEff ----

## class ----

#' `ModelEff`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelEff`] is the parent class for efficacy models using pseudo data prior.
#' It is dedicated all efficacy models that have their prior specified in the
#' form of pseudo data (as if there is some data before the trial starts).
#'
#' The `data` must obey the convention of the [`DataDual`] class. This refers to
#' any observed efficacy/biomarker responses (`w` in [`DataDual`]), the dose
#' levels at which these responses are observed (`x` in [`DataDual`]), all dose
#' levels considered in the study (`doseGrid` in [`DataDual`]), and finally
#' other specifications in [`DataDual`] class that can be used to generate prior
#' or posterior modal estimates or samples estimates for model parameter(s).
#' If no responses are observed, at least `doseGrid` has to be specified
#' in `data` for which prior modal estimates or samples can be obtained for
#' model parameters based on the specified pseudo data.
#'
#' @slot data (`DataDual`)\cr observed data that is used to obtain model
#'   parameters estimates or samples (see details above).
#'
#' @seealso [`ModelTox`].
#'
#' @aliases ModelEff
#' @export
#'
.ModelEff <- setClass(
  Class = "ModelEff",
  slots = c(
    data = "DataDual"
  ),
  contains = "ModelPseudo"
)

## default constructor ----

#' @rdname ModelEff-class
#' @note Typically, end users will not use the `.DefaultModelEff()` function.
#' @export
.DefaultModelEff <- function() {
  stop(paste0(
    "Class ModelEff should not be instantiated directly.  Please use one of its subclasses instead."
  ))
}

# LogisticIndepBeta ----

## class ----

#' `LogisticIndepBeta`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticIndepBeta`] is the class for the two-parameters logistic regression
#' dose-limiting events (DLE) model with prior expressed in form of pseudo data.
#' This model describes the relationship between the binary DLE responses
#' and the dose levels. More specifically, it represents the relationship of the
#' probabilities of the occurrence of a DLE for corresponding dose levels in log
#' scale. This model is specified as
#' \deqn{p(x) = exp(phi1 + phi2 * log(x)) / (1 + exp(phi1 + phi2 * log(x)))}
#' where \eqn{p(x)} is the probability of the occurrence of a DLE at dose \eqn{x}.
#' The two parameters of this model are the intercept \eqn{phi1} and the slope
#' \eqn{phi2}. The `LogisticIndepBeta` inherits all slots from [`ModelTox`] class.
#'
#' In the context of pseudo data, the following three arguments are used,
#' `binDLE`, `DLEdose` and `DLEweights`. The `DLEdose` represents fixed dose
#' levels at which the pseudo DLE responses `binDLE` are observed. `DLEweights`
#' represents total number of subjects treated per each dose level in `DLEdose`.
#' The `binDLE` represents the number of subjects observed with DLE per each
#' dose level in `DLEdose`. Hence, all these three vectors must be of the same
#' length and the order of the elements in any of the vectors `binDLE`,
#' `DLEdose` and `DLEweights` must be kept, so that an element of a given vector
#' corresponds to the elements of the remaining two vectors (see the example for
#' more insight).
#' Finally, since at least two DLE pseudo responses are needed to
#' obtain prior modal estimates (same as the maximum likelihood estimates) for
#' the model parameters, the `binDLE`, `DLEdose` and `DLEweights` must all be
#' vectors of at least length 2.
#'
#' @details The pseudo data can be interpreted as if we obtain some observations
#'   before the trial starts. It can be used to express our prior, i.e. the
#'   initial beliefs for the model parameters. The pseudo data is expressed in
#'   the following way. First, fix at least two dose levels, then ask for experts'
#'   opinion on how many subjects are to be treated at each of these dose levels
#'   and on the number of subjects observed with a DLE. At each dose level, the
#'   number of subjects observed with a DLE, divided by the total number of
#'   subjects treated, is the probability of the occurrence of a DLE at that
#'   particular dose level. The probabilities of the occurrence of a DLE based
#'   on this pseudo data are independent and they follow Beta distributions.
#'   Therefore, the joint prior probability density function of all these
#'   probabilities can be obtained. Hence, by a change of variable, the joint
#'   prior probability density function of the two parameters in this model can
#'   also be obtained. In addition, a conjugate joint prior density function of
#'   the two parameters in the model is used. For details about the form of all
#'   these joint prior and posterior probability density functions, please refer
#'   to Whitehead and Willamson (1998).
#'
#' @slot binDLE (`numeric`)\cr a vector of total numbers of DLE responses.
#'   It must be at least of length 2 and the order of its elements must
#'   correspond to values specified in `DLEdose` and `DLEweights`.
#' @slot DLEdose (`numeric`)\cr a vector of the dose levels corresponding to
#'   It must be at least of length 2 and the order of its elements must
#'   correspond to values specified in `binDLE` and `DLEweights`.
#' @slot DLEweights (`integer`)\cr total number of subjects treated at each of
#'   the pseudo dose level `DLEdose`.
#'   It must be at least of length 2 and the order of its elements must
#'   correspond to values specified in `binDLE` and `DLEdose`.
#' @slot phi1 (`number`)\cr  the intercept of the model. This slot is used in
#'   output to display the resulting prior or posterior modal estimate of the
#'   intercept obtained based on the pseudo data and (if any) observed data/responses.
#' @slot phi2 (`number`)\cr  the slope of the model. This slot is used in output
#'   to display the resulting prior or posterior modal estimate of the slope
#'   obtained based on the pseudo data and (if any) the observed data/responses.
#' @slot Pcov (`matrix`)\cr refers to the 2x2 covariance matrix of the intercept
#'   (\eqn{phi1}) and the slope parameters (\eqn{phi2}) of the model.
#'   This is used in output to display the resulting prior and posterior
#'   covariance matrix of \eqn{phi1} and \eqn{phi2} obtained, based on the
#'   pseudo data and (if any) the observed data and responses. This slot is
#'   needed for internal purposes.
#'
#' @aliases LogisticIndepBeta
#' @export
#'
.LogisticIndepBeta <- setClass(
  Class = "LogisticIndepBeta",
  slots = c(
    binDLE = "numeric",
    DLEdose = "numeric",
    DLEweights = "integer",
    phi1 = "numeric",
    phi2 = "numeric",
    Pcov = "matrix"
  ),
  prototype = prototype(
    binDLE = c(0, 0),
    DLEdose = c(1, 1),
    DLEweights = c(1L, 1L)
  ),
  contains = "ModelTox",
  validity = v_model_logistic_indep_beta
)

## constructor ----

#' @rdname LogisticIndepBeta-class
#'
#' @param binDLE (`numeric`)\cr the number of subjects observed with a DLE, the
#'   pseudo DLE responses, depending on dose levels `DLEdose`.
#'   Elements of `binDLE` must correspond to the elements of `DLEdose` and
#'   `DLEweights`.
#' @param DLEdose (`numeric`)\cr dose levels for the pseudo DLE responses.
#'   Elements of `DLEdose` must correspond to the elements of `binDLE` and
#'   `DLEweights`.
#' @param DLEweights (`numeric`)\cr the total number of subjects treated at each
#'   of the dose levels `DLEdose`, pseudo weights.
#'   Elements of `DLEweights` must correspond to the elements of `binDLE` and
#'   `DLEdose`.
#' @param data (`Data`)\cr the input data to update estimates of the model
#'   parameters.
#'
#' @export
#' @example examples/Model-class-LogisticIndepBeta.R
#'
LogisticIndepBeta <- function(binDLE, DLEdose, DLEweights, data) {
  assert_numeric(binDLE)
  assert_numeric(DLEdose)
  assert_integerish(DLEweights, lower = 0, any.missing = FALSE)
  assert_class(data, "Data")

  # Combine pseudo and observed data. It can also happen that data@nObs == 0.
  y <- c(binDLE, data@y)
  x <- c(DLEdose, data@x)
  w <- c(DLEweights, rep(1, data@nObs))

  fit_dle <- suppressWarnings(
    glm(y / w ~ log(x), family = binomial(link = "logit"), weights = w)
  )
  phi1 <- coef(fit_dle)[["(Intercept)"]]
  phi2 <- coef(fit_dle)[["log(x)"]]
  Pcov <- vcov(fit_dle)

  .LogisticIndepBeta(
    binDLE = binDLE,
    DLEdose = DLEdose,
    DLEweights = as.integer(DLEweights),
    phi1 = phi1,
    phi2 = phi2,
    Pcov = Pcov,
    data = data
  )
}

## default constructor ----

#' @rdname LogisticIndepBeta-class
#' @note Typically, end users will not use the `.DefaultLogisticIndepBeta()` function.
#' @export
.DefaultLogisticIndepBeta <- function() {
  my_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3L, 3L),
    DLEdose = c(25, 300),
    data = Data(doseGrid = seq(25, 300, 25))
  )
}


# Effloglog ----

## class ----

#' `Effloglog`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Effloglog`] is the class for the linear log-log efficacy model using pseudo
#' data prior. It describes the relationship between continuous efficacy
#' responses and corresponding dose levels in log-log scale. This efficacy
#' log-log model is given as
#' \deqn{y_i = theta1 + theta2 * log(log(x_i)) + epsilon_i,}
#' where \eqn{y_i} is the efficacy response for subject \eqn{i}, \eqn{x_i} is
#' the dose level treated for subject \eqn{i} and \eqn{epsilon_i} is the random
#' error term of efficacy model at subject \eqn{i}. The error term
#' \eqn{epsilon_i} is a random variable that follows normal distribution with
#' mean \eqn{0} and variance \eqn{nu^{-1}}, which is assumed to be the
#' same for all subjects.
#' There are three parameters in this model, the intercept \eqn{theta1}, the
#' slope \eqn{theta2} and the precision \eqn{nu} of the efficacy responses, also
#' known as the inverse of the variance of the pseudo efficacy responses. It can
#' be a fixed constant or having a gamma distribution. Therefore, a single scalar
#' value or a vector with two positive numbers values must be specified for `nu`
#' slot. If there are some observed efficacy responses available, in the output,
#' `nu` will display the updated value of the precision or the updated values
#' for the parameters of the gamma distribution.
#' The `Effloglog` inherits all slots from [`ModelEff`] class.
#'
#' @details The prior of this model is specified in form of pseudo data. First,
#'   at least two dose levels are fixed. Then, using e.g. experts' opinion, the
#'   efficacy values that correspond to these dose levels can be obtained,
#'   The `eff` and `eff_dose` arguments represent the prior in form of the pseudo
#'   data. The `eff` represents the pseudo efficacy values. The `eff_dose`
#'   represents the dose levels at which these pseudo efficacy values are
#'   observed. Hence, the positions of the elements specified in `eff` and
#'   `eff_dose` must correspond to each other between these vectors.
#'   Since at least 2 pseudo efficacy values are needed to obtain modal
#'   estimates of the intercept and slope parameters, both `eff` and `eff_dose`
#'   must be vectors of length at least 2.
#'
#'   The joint prior distribution of the intercept \eqn{theta1} and the slope
#'   \eqn{theta2} of this model follows bivariate normal distribution with mean
#'   \eqn{mu} and covariance matrix \eqn{(nu * Q)^{-1}}.
#'   The mean \eqn{mu} is a \eqn{2 x 1} column vector that contains the prior
#'   modal estimates of the intercept and the slope.
#'   Scalar \eqn{nu} is the precision of the pseudo efficacy responses and
#'   \eqn{Q} is the prior or posterior (given that observed, no DLT data is
#'   available) precision matrix.
#'   It is specified as \eqn{Q = X0^T * X0 + X^T * X}, where \eqn{X0} is a
#'   design matrix that is based on pseudo dose levels only, and \eqn{X} is a
#'   design matrix that is based on dose levels corresponding to the no DLT
#'   efficacy responses observed only (if any).
#'   Hence, the \eqn{X0} (or \eqn{X}) will be of size \eqn{r x 2}, if
#'   there are \eqn{r >= 2} pseudo efficacy responses specified (or
#'   if there are \eqn{r} no DLT efficacy responses observed in the `data`).
#'
#' @slot eff (`numeric`)\cr the pseudo efficacy responses. Each element here
#'   must represent responses treated based on one subject.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff_dose`.
#' @slot eff_dose (`numeric`)\cr the pseudo efficacy dose levels at which the
#'   pseudo efficacy responses are observed.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff`.
#' @slot nu (`numeric`)\cr parameter of the prior precision of pseudo efficacy
#'   responses. This is either a fixed value or a named vector with two positive
#'   numbers, the shape (`a`), and the rate (`b`) parameters for the gamma
#'   distribution.
#' @slot use_fixed (`flag`)\cr indicates whether `nu` specified is a fixed value
#'   or a vector with two parameters for gamma distribution. This slot is for
#'   internal purposes only and must not be used by the user.
#' @slot theta1 (`number`)\cr the intercept in this efficacy log-log model. This
#'   slot is used in output to display the resulting prior or posterior modal
#'   estimates obtained based on the pseudo and observed (if any) data.
#' @slot theta2 (`number`)\cr the slope in this efficacy log-log model. This
#'   slot is used in output to display the resulting prior or posterior modal
#'   estimates obtained based on the pseudo and observed (if any) data.
#' @slot Pcov (`matrix`)\cr refers to the \eqn{2 x 2} covariance matrix of the
#'   estimators of the intercept \eqn{theta1} and the slope \eqn{theta2}
#'   parameters in this model.
#'   This is used in output to display the resulting prior and posterior
#'   covariance matrix of \eqn{theta1} and \eqn{theta2} obtained, based on the
#'   pseudo and observed (if any) data. This slot is needed for internal purposes.
#' @slot X (`matrix`)\cr is the design matrix that is based on either the pseudo
#'   dose levels or observed dose levels (without DLT). This is used
#'   in the output to display the design matrix for the pseudo or the observed
#'   efficacy responses.
#' @slot Y (`numeric`)\cr is a vector that either contains the pseudo efficacy
#'   responses or observed efficacy responses (without DLT).
#' @slot mu (`numeric`)\cr a vector of the prior or the posterior modal estimates
#'   of the intercept (\eqn{theta1}) and the slope (\eqn{theta2}).
#'   This slot is used in output to display as the mean of the prior or posterior
#'   bivariate normal distribution for \eqn{theta1} and \eqn{theta2}.
#' @slot Q (`matrix`)\cr is the prior or posterior (given that observed, no DLT
#'   data is available) precision matrix. It is specified as
#'   \eqn{Q = X0^T * X0 + X^T * X}, where \eqn{X0} is a design matrix that is
#'   based on pseudo dose levels only, and \eqn{X} is a design matrix that is
#'   based on dose levels corresponding to the observed, no DLT efficacy values
#'   only (if any).
#' @slot const (`number`)\cr a non-negative number (default to 0), leading to the
#'   model form described above. In general, the model has the form
#'   \eqn{y_i = theta1 + theta2 * log(log(x_i + const)) + epsilon_i}, such that
#'   dose levels greater than \eqn{1 - const} can be considered as described in
#'   Yeung et al. (2015).
#'
#' @aliases Effloglog
#' @export
#'
.Effloglog <- setClass(
  Class = "Effloglog",
  slots = c(
    eff = "numeric",
    eff_dose = "numeric",
    nu = "numeric",
    use_fixed = "logical",
    theta1 = "numeric",
    theta2 = "numeric",
    Pcov = "matrix",
    X = "matrix",
    Y = "numeric",
    mu = "numeric",
    Q = "matrix",
    const = "numeric"
  ),
  prototype = prototype(
    eff = c(0, 0),
    eff_dose = c(1, 1),
    nu = 1 / 0.025,
    use_fixed = TRUE,
    const = 0
  ),
  contains = "ModelEff",
  validity = v_model_eff_log_log
)

## constructor ----

#' @rdname Effloglog-class
#'
#' @param eff (`numeric`)\cr the pseudo efficacy responses.
#'   Elements of `eff` must correspond to the elements of `eff_dose`.
#' @param eff_dose (`numeric`)\cr dose levels that correspond to pseudo efficacy
#'   responses in `eff`.
#' @param nu (`numeric`)\cr the precision (inverse of the variance) of the
#'   efficacy responses. This is either a fixed value or a named vector with two
#'   positive numbers, the shape (`a`), and the rate (`b`) parameters for the
#'   gamma distribution.
#' @param data (`DataDual`)\cr observed data to update estimates of the model
#'   parameters.
#' @param const (`number`)\cr the constant value added to the dose level when
#'   the dose level value is less than or equal to 1 and a special form of the
#'   linear log-log has to applied (Yeung et al. (2015).).
#'
#' @export
#' @example examples/Model-class-Effloglog.R
#'
Effloglog <- function(eff, eff_dose, nu, data, const = 0) {
  assert_numeric(eff)
  assert_numeric(eff_dose, len = length(eff))
  assert_numeric(nu, min.len = 1, max.len = 2)
  assert_class(data, "Data")
  assert_number(const, finite = TRUE)

  use_fixed <- length(nu) == 1L

  eff_dose <- eff_dose + const
  # Get observed efficacy data without DLT (if any).
  eff_obsrv_w_x <- getEff(data, no_dlt = TRUE)
  eff_obsrv <- eff_obsrv_w_x$w_no_dlt
  eff_obsrv_dose <- eff_obsrv_w_x$x_no_dlt + const

  # Fit pseudo and observed (if any) efficacy.
  w <- c(eff, eff_obsrv)
  x <- c(eff_dose, eff_obsrv_dose)
  fit_eff <- suppressWarnings(lm(w ~ log(log(x))))
  X <- model.matrix(fit_eff)
  Y <- w
  mu <- coef(fit_eff) # This is [theta1, theta2]^T est.
  Q <- crossprod(X)
  Pcov <- vcov(fit_eff)

  nobs_no_dlt <- length(eff_obsrv)
  if (nobs_no_dlt > 0L) {
    # Observed data available.
    # Set X, Y to observed data only.
    X <- model.matrix(fit_eff)[-seq_along(eff), ]
    Y <- eff_obsrv

    fit_eff0 <- lm(eff ~ log(log(eff_dose))) # Pseudo only.
    X0 <- model.matrix(fit_eff0)
    mu0 <- coef(fit_eff0)
    Q0 <- crossprod(X0)
    # Note that mu = (Q0 + X^T * X)^{-1} * (Q0 * mu0 + X^T * X * (X^T * X)^{-1} X^T * Y),
    # given that (X^T * X) is invertible and X, Y, mu0, Q0, are specified in this else block.
    if (!use_fixed) {
      nu["a"] <- nu["a"] + (nobs_no_dlt) / 2
      nu["b"] <- nu["b"] +
        (crossprod(Y) + t(mu0) %*% Q0 %*% mu0 - t(mu) %*% Q %*% mu) / 2
    }
  }

  .Effloglog(
    eff = eff,
    eff_dose = eff_dose,
    nu = nu,
    use_fixed = use_fixed,
    theta1 = mu[["(Intercept)"]],
    theta2 = mu[["log(log(x))"]],
    Pcov = Pcov,
    X = X,
    Y = Y,
    mu = as.vector(mu),
    Q = Q,
    const = const,
    data = data
  )
}

## default constructor ----

#' @rdname Effloglog-class
#' @note Typically, end users will not use the `.DefaultEffloglog()` function.
#' @export
.DefaultEffloglog <- function() {
  emptydata <- DataDual(doseGrid = seq(25, 300, 25), placebo = FALSE)

  my_data <- DataDual(
    x = c(25, 50, 50, 75, 100, 100, 225, 300),
    y = c(0, 0, 0, 0, 1, 1, 1, 1),
    w = c(0.31, 0.42, 0.59, 0.45, 0.6, 0.7, 0.6, 0.52),
    doseGrid = emptydata@doseGrid,
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 2, 3, 4, 4, 5, 6))
  )

  Effloglog(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    nu = c(a = 1, b = 0.025),
    data = my_data
  )
}

# EffFlexi ----

## class ----

#' `EffFlexi`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`EffFlexi`] is the class for the efficacy model in flexible form of prior
#' expressed in form of pseudo data. In this class, a flexible form is used to
#' describe the relationship between the efficacy responses and the dose levels
#' and it is specified as
#' \deqn{(W | betaW, sigma2W) ~ Normal(X * betaW, sigma2W * I),}
#' where \eqn{W} is a vector of the efficacy responses, \eqn{betaW} is a column
#' vector of the mean efficacy responses for all dose levels, and \eqn{X} is
#' the design matrix with entries \eqn{I_i,j} that are equal to 1 if subject
#' \eqn{i} is allocated to dose \eqn{j}, and \eqn{0} otherwise. The \eqn{sigma2W}
#' is the variance of the efficacy responses which can be either a fixed number
#' or a number from an inverse gamma distribution.
#' This flexible form aims to capture different shapes of the dose-efficacy
#' curve. In addition, the first (RW1) or second order (RW2) random walk model
#' can be used for smoothing data. That is the random walk model is used to model
#' the first or the second order differences of the mean efficacy responses to
#' its neighboring dose levels of their mean efficacy responses.
#'
#' The RW1 model is given as
#' \deqn{betaW_j - betaW_j-1) ~ Normal(0, sigma2betaW),}
#' and for RW2 as
#' \deqn{betaW_j-2 - 2 * betaW_j-1 + beta_j ~ Normal(0, sigma2betaW),}
#' where \eqn{betaW_j} is the vector of mean efficacy responses at dose j, and
#' the \eqn{sigma2betaW} is the prior variance which can be either a fixed
#' number or a number from an inverse gamma distribution.
#'
#' The `eff` and `eff_dose` are the pseudo efficacy responses and dose levels at
#' which these pseudo efficacy responses are observed. Both, `eff` and `eff_dose`
#' must be vectors of length at least 2. The positions of the elements specified
#' in `eff` and `eff_dose` must correspond to each other between these vectors.
#'
#' @details This model will output the updated value or the updated values of the
#'   parameters of the inverse gamma distributions for \eqn{sigma2W} and
#'   \eqn{sigma2betaW}. The `EffFlexi` inherits all slots from [`ModelEff`] class.
#'
#' @slot eff (`numeric`)\cr the pseudo efficacy responses. Each element here
#'   must represent responses treated based on one subject.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff_dose`.
#' @slot eff_dose (`numeric`)\cr the pseudo efficacy dose levels at which the
#'   pseudo efficacy responses are observed.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff`.
#' @slot sigma2W (`numeric`)\cr the prior variance of the flexible efficacy form.
#'   This is either a fixed value or a named vector with two positive numbers,
#'   the shape (`a`), and the rate (`b`) parameters for the gamma distribution.
#' @slot sigma2betaW (`numeric`)\cr the prior variance of the random walk model
#'   for the mean efficacy responses. This is either a fixed value or a named
#'   vector with two positive numbers, the shape (`a`), and the rate (`b`)
#'   parameters for the gamma distribution.
#' @slot use_fixed (`logical`)\cr indicates whether a fixed value for
#'   `sigma2W` and `sigma2betaW` (for each parameter separately) is used or not.
#'   This slot is needed for internal purposes and must not be touched by the user.
#' @slot rw1 (`flag`)\cr used for smoothing data for this efficacy model. If it
#'   is `TRUE`, the first-order random walk model is used for the mean efficacy
#'   responses. Otherwise, the random walk of second order is used.
#' @slot X (`matrix`)\cr the design matrix for the efficacy responses. It is
#'   based on both the pseudo and the observed efficacy responses.
#' @slot RW (`matrix`)\cr the difference matrix for the random walk model. This
#'   slot is needed for internal purposes and must not be used by the user.
#' @slot RW_rank (`integer`)\cr is the rank of the difference matrix. This
#'   slot is needed for internal purposes and must not be used by the user.
#'
#' @aliases EffFlexi
#' @export
#'
.EffFlexi <- setClass(
  Class = "EffFlexi",
  slots = c(
    eff = "numeric",
    eff_dose = "numeric",
    sigma2W = "numeric",
    sigma2betaW = "numeric",
    use_fixed = "logical",
    rw1 = "logical",
    X = "matrix",
    RW = "matrix",
    RW_rank = "integer"
  ),
  prototype = prototype(
    eff = c(0, 0),
    eff_dose = c(1, 1),
    sigma2W = 0.025,
    sigma2betaW = 1,
    rw1 = TRUE,
    use_fixed = c(sigma2W = TRUE, sigma2betaW = TRUE)
  ),
  contains = "ModelEff",
  validity = v_model_eff_flexi
)

## constructor ----

#' @rdname EffFlexi-class
#'
#' @param eff (`numeric`)\cr the pseudo efficacy responses.
#'   Elements of `eff` must correspond to the elements of `eff_dose`.
#' @param eff_dose (`numeric`)\cr dose levels that correspond to pseudo efficacy
#'   responses in `eff`.
#' @param sigma2W (`numeric`)\cr the prior variance of the efficacy responses.
#'   This is either a fixed value or a named vector with two positive numbers,
#'   the shape (`a`), and the rate (`b`) parameters for the inverse gamma
#'   distribution.
#' @param sigma2betaW (`numeric`)\cr the prior variance of the random walk model
#'   used for smoothing. This is either a fixed value or a named vector with two
#'   positive numbers, the shape (`a`), and the rate (`b`) parameters for the
#'   inverse gamma distribution.
#' @param rw1 (`flag`)\cr used for smoothing data for this efficacy model. If it
#'   is `TRUE`, the first-order random walk model is used for the mean efficacy
#'   responses. Otherwise, the random walk of second order is used.
#' @param data (`DataDual`)\cr observed data to update estimates of the model
#'   parameters.
#'
#' @export
#' @example examples/Model-class-EffFlexi.R
#'
EffFlexi <- function(eff, eff_dose, sigma2W, sigma2betaW, rw1 = TRUE, data) {
  assert_numeric(eff)
  assert_numeric(eff_dose)
  assert_numeric(sigma2W, min.len = 1, max.len = 2)
  assert_numeric(sigma2betaW, min.len = 1, max.len = 2)
  assert_flag(rw1)
  assert_class(data, "DataDual")

  use_fixed <- c(
    sigma2W = test_number(sigma2W),
    sigma2betaW = test_number(sigma2betaW)
  )

  x <- c(eff_dose, getEff(data, no_dlt = TRUE)$x_no_dlt)
  x_level <- match_within_tolerance(x, data@doseGrid)
  X <- model.matrix(~ -1L + factor(x_level, levels = seq_len(data@nGrid)))
  X <- matrix(as.integer(X), ncol = ncol(X)) # To remove some obsolete attributes.

  # Set up the random walk penalty matrix and its rank.
  # D1: difference matrix of order 1.
  D1 <- cbind(0, diag(data@nGrid - 1)) - cbind(diag(data@nGrid - 1), 0)
  if (rw1) {
    # the rank-deficient prior precision for the RW1 prior.
    RW <- crossprod(D1)
    RW_rank <- data@nGrid - 1L # rank = dimension - 1. # nolintr
  } else {
    # Second-order difference.
    D2 <- D1[-1, -1] %*% D1
    RW <- crossprod(D2)
    RW_rank <- data@nGrid - 2L # nolintr
  }

  .EffFlexi(
    eff = eff,
    eff_dose = eff_dose,
    sigma2W = sigma2W,
    sigma2betaW = sigma2betaW,
    use_fixed = use_fixed,
    rw1 = rw1,
    X = X,
    RW = RW,
    RW_rank = RW_rank,
    data = data
  )
}

## default constructor ----

#' @rdname EffFlexi-class
#' @note Typically, end users will not use the `.DefaultEffFlexi()` function.
#' @export
.DefaultEffFlexi <- function() {
  empty_data <- DataDual(doseGrid = seq(25, 300, 25))
  EffFlexi(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    sigma2W = c(a = 0.1, b = 0.1),
    sigma2betaW = c(a = 20, b = 50),
    rw1 = FALSE,
    data = empty_data
  )

  data <- DataDual(
    x = c(25, 50, 50, 75, 100, 100, 225, 300),
    y = c(0, 0, 0, 0, 1, 1, 1, 1),
    w = c(0.31, 0.42, 0.59, 0.45, 0.6, 0.7, 0.6, 0.52),
    doseGrid = empty_data@doseGrid,
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 2, 3, 4, 4, 5, 6))
  )

  EffFlexi(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    sigma2W = c(a = 0.1, b = 0.1),
    sigma2betaW = c(a = 20, b = 50),
    rw1 = FALSE,
    data = data
  )
}

# DALogisticLogNormal ----

## class ----

#' `DALogisticLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DALogisticLogNormal`] is the class for the logistic model with bivariate
#' (log) normal prior and data augmentation. This class inherits from the
#' [`LogisticLogNormal`] class.
#'
#' @note We still need to include here formula for the lambda prior.
#'
#' @slot npiece (`number`)\cr the number of pieces in the `PEM`.
#' @slot l (`numeric`)\cr a vector used in the lambda prior.
#' @slot c_par (`numeric`)\cr a parameter used in the lambda prior; according to
#'   Liu's paper, `c_par = 2` is recommended.
#' @slot cond_pem (`flag`)\cr is a conditional piecewise-exponential model used?
#'   (default). Otherwise an unconditional model is used.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormal`].
#'
#' @aliases DALogisticLogNormal
#' @export
#'
.DALogisticLogNormal <- setClass(
  Class = "DALogisticLogNormal",
  slots = c(
    npiece = "integer",
    l = "numeric",
    c_par = "numeric",
    cond_pem = "logical"
  ),
  prototype = prototype(
    npiece = 3L,
    l = 0.5,
    c_par = 2,
    cond_pem = TRUE
  ),
  contains = "LogisticLogNormal",
  validity = v_model_da_logistic_log_normal
)

## constructor ----

#' @rdname DALogisticLogNormal-class
#'
#' @param npiece (`number`)\cr the number of pieces in the `PEM`.
#' @param l (`numeric`)\cr a vector used in the lambda prior.
#' @param c_par (`numeric`)\cr a parameter used in the lambda prior; according to
#'   Liu's paper, `c_par = 2` is recommended.
#' @param cond_pem (`flag`)\cr is a conditional piecewise-exponential model used?
#'   (default). Otherwise an unconditional model is used.
#' @inheritDotParams LogisticLogNormal
#'
#' @export
#' @example examples/Model-class-DALogisticLogNormal.R
#'
DALogisticLogNormal <- function(
  npiece = 3,
  l,
  c_par = 2,
  cond_pem = TRUE,
  ...
) {
  assert_flag(cond_pem)

  start <- LogisticLogNormal(...)

  datamodel <- function() {
    for (i in 1:nObs) {
      # Part I: describe the logistic model of DLTs vs dose.
      logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)

      # Part II: describe the piecewise exponential.
      # Notice that:
      # when y=1             -> DLT=1 and u=<T;
      # when y=0 & T<t (u=T) -> DLT=0;
      # when y=0 & T>t (u<T) -> DLT=NA/missing;
      # when indx=0 -> censored, i.e u<T and event=0;
      # when indx=1 -> not censored, i.e. u>=T or event=1;
      indx[i] <- 1 - step(Tmax - u[i] - eps) * (1 - y[i])

      for (j in 1:npiece) {
        # When not censored, i.e DLT!=NA & t[i]=u[i];
        # if t[i]<h[j], d[i,j]=0;
        # if h[j]<t[i]=<h[j+1], d[i,j]=1
        # if h[j+1]<t[i], d[i,j]=0
        # When censored t[i]>u[i] -> d[i,j]=0
        d[i, j] <- y[i] * step(u[i] - h[j] - eps) * step(h[j + 1] - u[i])

        # DLT free survival(time) for patient i in interval I(j);
        # if t[i]<h[j], s[i,j]=0;
        # if h[j]<t[i]<=h[j+1], s[i,j]=t[i]-h[j]
        # if h[j+1]<=t[i], s[i,j]=h[j+1]-h[j]
        s[i, j] <- min(u[i] - h[j], h[j + 1] - h[j]) * step(u[i] - h[j])

        # piecewise exponential hazard rate lambda[j];
        mu_u[i, j] <- lambda[j] * s[i, j]
        mu[i, j] <- d[i, j] * log(lambda[j]) - y[i] * mu_u[i, j]
      }

      # The likelihood function.
      L_obs[i] <- exp(sum(mu[i, ])) *
        pow(p[i] / A, y[i]) *
        pow(1 - p[i], 1 - y[i]) # Not censored. # nolintr
      L_cnsr[i] <- 1 - p[i] * (1 - exp(-sum(mu_u[i, ]))) / A # Censored. # nolintr
      L[i] <- pow(L_obs[i], indx[i]) * pow(L_cnsr[i], 1 - indx[i])

      # Apply zero trick in JAGS.
      phi[i] <- -log(L[i]) + cadj
      zeros[i] ~ dpois(phi[i])
    }
  }

  priormodel <- h_jags_join_models(
    start@priormodel,
    function() {
      g_beta <- 1 / c_par
      for (j in 1:npiece) {
        g_alpha[j] <- l[j] / c_par
        lambda[j] ~ dgamma(g_alpha[j], g_beta)
        mu_T[j] <- lambda[j] * (h[j + 1] - h[j]) # nolintr
      }
      # If cond = 1, then conditional PEM is used and A is defined as
      # the probability to have DLT, i.e. t<T, otherwise
      # cond = 0 and A is just 1 (so no impact in likelihood).
      A <- cond * (1 - exp(-sum(mu_T))) + (1 - cond)
    }
  )

  modelspecs <- function(nObs, Tmax, from_prior) {
    ms <- list(
      prec = start@params@prec,
      mean = start@params@mean,
      npiece = npiece,
      l = l,
      c_par = c_par,
      h = seq(from = 0L, to = Tmax, length = npiece + 1),
      cond = as.integer(cond_pem)
    )
    if (!from_prior) {
      ms <- c(
        list(
          ref_dose = start@ref_dose,
          zeros = rep(0, nObs),
          eps = 1e-10,
          cadj = 1e10
        ),
        ms
      )
    }
    ms
  }

  assert_integerish(npiece, lower = 1)

  .DALogisticLogNormal(
    start,
    npiece = as.integer(npiece),
    l = l,
    c_par = c_par,
    cond_pem = cond_pem,
    datamodel = datamodel,
    priormodel = priormodel,
    modelspecs = modelspecs,
    datanames = c("nObs", "y", "x", "u", "Tmax"),
    sample = c("alpha0", "alpha1", "lambda")
  )
}

## default constructor ----

#' @rdname DALogisticLogNormal-class
#' @note Typically, end users will not use the `.DefaultDALogisticLogNormal()` function.
#' @export
.DefaultDALogisticLogNormal <- function() {
  npiece <- 10
  Tmax <- 60

  lambda_prior <- function(k) {
    npiece / (Tmax * (npiece - k + 0.5))
  }

  DALogisticLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 56,
    npiece = npiece,
    l = as.numeric(t(apply(
      as.matrix(c(1:npiece), 1, npiece),
      2,
      lambda_prior
    ))),
    c_par = 2
  )
}

# TITELogisticLogNormal ----

## class ----

#' `TITELogisticLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`TITELogisticLogNormal`] is the class for TITE-CRM based on a logistic
#' regression model using a bivariate normal prior on the intercept and log
#' slope parameters.
#'
#' This class inherits from the [`LogisticLogNormal`].
#'
#' @slot weight_method (`string`)\cr the weight function method: either linear
#'   or adaptive. This was used in Liu, Yin and Yuan's paper.
#'
#' @seealso [`DALogisticLogNormal`].
#'
#' @aliases TITELogisticLogNormal
#' @export
#'
.TITELogisticLogNormal <- setClass(
  Class = "TITELogisticLogNormal",
  slots = c(weight_method = "character"),
  prototype = prototype(weight_method = "linear"),
  contains = "LogisticLogNormal",
  validity = v_model_tite_logistic_log_normal
)

## constructor ----

#' @rdname TITELogisticLogNormal-class
#'
#' @param weight_method (`string`)\cr the weight function method: either linear
#'   or adaptive. This was used in Liu, Yin and Yuan's paper.
#' @inheritDotParams LogisticLogNormal
#'
#' @export
#' @example examples/Model-class-TITELogisticLogNormal.R
#'
TITELogisticLogNormal <- function(weight_method = "linear", ...) {
  assert_character(
    weight_method,
    min.len = 1L,
    max.len = 2L,
    any.missing = FALSE
  )

  start <- LogisticLogNormal(...)

  datamodel <- function() {
    for (i in 1:nObs) {
      logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)

      # The piecewise exponential likelihood. Notice that:
      # when y=1             -> DLT=1 and u=<T;
      # when y=0 & T<t (u=T) -> DLT=0;
      # when y=0 & T>t (u<T) -> DLT=NA/missing;
      # when indx=0 -> censored, i.e u<T and event=0;
      # when indx=1 -> not censored, i.e. u>=T or event=1;
      L[i] <- pow(p[i], y[i]) * pow((1 - w[i] * p[i]), (1 - y[i]))

      # Apply zero trick in JAGS.
      phi[i] <- -log(L[i]) + cadj
      zeros[i] ~ dpois(phi[i])
    }
  }

  modelspecs <- function(nObs, u, Tmax, y, from_prior) {
    ms <- list(prec = start@params@prec, mean = start@params@mean)
    # Calculate weights `w` based on the input data.
    if (!from_prior && nObs > 0L) {
      if (weight_method == "linear") {
        w <- u / Tmax
      } else if (weight_method == "adaptive") {
        nDLT <- sum(y)
        if (nDLT > 0) {
          u_dlt <- sort(u[y == 1])
          w <- sapply(u, function(u_i) {
            m <- sum(u_i >= u_dlt)
            w_i <- if (m == 0) {
              u_i / u_dlt[1]
            } else if (m < nDLT) {
              m + (u_i - u_dlt[m]) / (u_dlt[m + 1] - u_dlt[m])
            } else {
              # m == nDLT. nolintr
              m + (u_i - u_dlt[m]) / (Tmax + 0.00000001 - u_dlt[m])
            }
            w_i / (nDLT + 1)
          })
        } else {
          w <- u / Tmax
        }
      }
      w[y == 1] <- 1
      w[u == Tmax] <- 1

      ms <- c(
        list(
          ref_dose = start@ref_dose,
          zeros = rep(0, nObs),
          cadj = 1e10,
          w = w
        ),
        ms
      )
    }
    ms
  }

  .TITELogisticLogNormal(
    start,
    weight_method = weight_method,
    datamodel = datamodel,
    modelspecs = modelspecs,
    datanames = c("nObs", "y", "x")
  )
}

## default constructor ----

#' @rdname TITELogisticLogNormal-class
#' @note Typically, end users will not use the `.DefaultTITELogisticLogNormal()` function.
#' @export
.DefaultTITELogisticLogNormal <- function() {
  TITELogisticLogNormal(
    mean = c(0, 1),
    cov = diag(2),
    ref_dose = 1,
    weight_method = "linear"
  )
}

# OneParLogNormalPrior ----

## class ----

#' `OneParLogNormalPrior`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`OneParLogNormalPrior`] is the class for a standard CRM with a normal prior on
#' the log power parameter for the skeleton prior probabilities.
#'
#' @slot skel_fun (`function`)\cr function to calculate the prior DLT probabilities.
#' @slot skel_fun_inv (`function`)\cr inverse function of `skel_fun`.
#' @slot skel_probs (`numeric`)\cr skeleton prior probabilities. This is a vector
#'   of unique and sorted probability values between 0 and 1.
#' @slot sigma2 (`number`)\cr prior variance of log power parameter alpha.
#'
#' @seealso [`ModelLogNormal`].
#'
#' @aliases OneParLogNormalPrior
#' @export
#'
.OneParLogNormalPrior <- setClass(
  Class = "OneParLogNormalPrior",
  slots = c(
    skel_fun = "function",
    skel_fun_inv = "function",
    skel_probs = "numeric",
    sigma2 = "numeric"
  ),
  contains = "GeneralModel",
  validity = v_model_one_par_exp_normal_prior
)

## constructor ----

#' @rdname OneParLogNormalPrior-class
#'
#' @param skel_probs (`numeric`)\cr skeleton prior probabilities. This is a vector
#'   of unique and sorted probability values between 0 and 1.
#' @param dose_grid (`numeric`)\cr dose grid. It must be must be a sorted vector
#'   of the same length as `skel_probs`.
#' @param sigma2 (`number`)\cr prior variance of log power parameter alpha.
#'
#' @export
#' @example examples/Model-class-OneParLogNormalPrior.R
#'
OneParLogNormalPrior <- function(skel_probs, dose_grid, sigma2) {
  assert_probabilities(skel_probs, unique = TRUE, sorted = TRUE) # So that skel_fun_inv exists.
  assert_numeric(
    dose_grid,
    len = length(skel_probs),
    any.missing = FALSE,
    unique = TRUE,
    sorted = TRUE
  )

  skel_fun <- approxfun(x = dose_grid, y = skel_probs, rule = 2)
  skel_fun_inv <- approxfun(x = skel_probs, y = dose_grid, rule = 2)

  .OneParLogNormalPrior(
    skel_fun = skel_fun,
    skel_fun_inv = skel_fun_inv,
    skel_probs = skel_probs,
    sigma2 = sigma2,
    datamodel = function() {
      for (i in 1:nObs) {
        p[i] <- skel_probs[xLevel[i]]^exp(alpha)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      alpha ~ dnorm(0, 1 / sigma2)
    },
    modelspecs = function(from_prior) {
      ms <- list(sigma2 = sigma2)
      if (!from_prior) {
        ms$skel_probs <- skel_probs
      }
      ms
    },
    init = function() {
      list(alpha = 1)
    },
    datanames = c("nObs", "y", "xLevel"),
    sample = "alpha"
  )
}

## default constructor ----

#' @rdname OneParLogNormalPrior-class
#' @return an instance of the `OneParLogNormalPrior` class
#' @export
.DefaultOneParLogNormalPrior <- function() {
  OneParLogNormalPrior(
    skel_probs = seq(from = 0.1, to = 0.9, length = 5),
    dose_grid = 1:5,
    sigma2 = 2
  )
}

# OneParExpPrior ----

## class ----

#' `OneParExpPrior`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`OneParExpPrior`] is the class for a standard CRM with an exponential prior
#' on the power parameter for the skeleton prior probabilities. It is an
#' implementation of a version of the one-parameter CRM (O’Quigley et al. 1990).
#'
#' @note Typically, end users will not use the `.DefaultOneparExpPrior()` function.
#'
#' @slot skel_fun (`function`)\cr function to calculate the prior DLT probabilities.
#' @slot skel_fun_inv (`function`)\cr inverse function of `skel_fun`.
#' @slot skel_probs (`numeric`)\cr skeleton prior probabilities. This is a vector
#'   of unique and sorted probability values between 0 and 1.
#' @slot lambda (`number`)\cr rate parameter of prior exponential distribution
#'   for theta.
#'
#' @aliases OneParExpPrior
#' @export
#'
.OneParExpPrior <- setClass(
  Class = "OneParExpPrior",
  slots = c(
    skel_fun = "function",
    skel_fun_inv = "function",
    skel_probs = "numeric",
    lambda = "numeric"
  ),
  contains = "GeneralModel",
  validity = v_model_one_par_exp_prior
)

## constructor ----

#' @rdname OneParExpPrior-class
#'
#' @param skel_probs see slot definition.
#' @param dose_grid (`numeric`)\cr dose grid. It must be must be a sorted vector
#'   of the same length as `skel_probs`.
#' @param lambda see slot definition.
#'
#' @export
#' @example examples/Model-class-OneParExpPrior.R
#'
OneParExpPrior <- function(skel_probs, dose_grid, lambda) {
  assert_probabilities(skel_probs, unique = TRUE, sorted = TRUE) # So that skel_fun_inv exists.
  assert_numeric(
    dose_grid,
    len = length(skel_probs),
    any.missing = FALSE,
    unique = TRUE,
    sorted = TRUE
  )

  skel_fun <- approxfun(x = dose_grid, y = skel_probs, rule = 2)
  skel_fun_inv <- approxfun(x = skel_probs, y = dose_grid, rule = 2)

  .OneParExpPrior(
    skel_fun = skel_fun,
    skel_fun_inv = skel_fun_inv,
    skel_probs = skel_probs,
    lambda = lambda,
    datamodel = function() {
      for (i in 1:nObs) {
        p[i] <- skel_probs[xLevel[i]]^theta
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      theta ~ dexp(lambda)
    },
    modelspecs = function(from_prior) {
      ms <- list(lambda = lambda)
      if (!from_prior) {
        ms$skel_probs <- skel_probs
      }
      ms
    },
    init = function() {
      list(theta = 1)
    },
    datanames = c("nObs", "y", "xLevel"),
    sample = "theta"
  )
}

## default constructor ----

#' @rdname OneParExpPrior-class
#' @note Typically, end users will not use the `.DefaultOneParLogNormalPrior()` function.
#' @export
.DefaultOneParExpPrior <- function() {
  OneParExpPrior(
    skel_probs = c(0.1, 0.3, 0.5, 0.7, 0.9),
    dose_grid = 1:5,
    lambda = 2
  )
}

# FractionalCRM ----

## class ----

#' `FractionalCRM`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`FractionalCRM`] is the class for a fractional CRM model based on a one
#' parameter CRM (with normal prior on the log-power parameter) as well as
#' Kaplan-Meier based estimation of the conditional probability to experience a
#' DLT for non-complete observations.
#'
#' This fractional CRM model follows the paper and code by Guosheng Yin et al.
#'
#' @seealso [`TITELogisticLogNormal`].
#'
#' @aliases FractionalCRM
#' @export
#'
.FractionalCRM <- setClass(
  Class = "FractionalCRM",
  contains = "OneParLogNormalPrior"
)

## constructor ----

#' @rdname FractionalCRM-class
#'
#' @inheritDotParams OneParLogNormalPrior
#'
#' @export
#' @example examples/Model-class-FractionalCRM.R
#'
FractionalCRM <- function(...) {
  start <- OneParLogNormalPrior(...)

  # This is adapted from the TITELogisticLogNormal class.
  datamodel <- function() {
    for (i in 1:nObs) {
      p[i] <- skel_probs[xLevel[i]]^exp(alpha)

      # The piecewise exponential likelihood. Notice that:
      # when y=1             -> DLT=1 and u=<T;
      # when y=0 & T<t (u=T) -> DLT=0;
      # when y=0 & T>t (u<T) -> DLT=NA/missing.
      # Therefore, `yhat` is used instead of `y` for the likelihood f. (see `modelspecs`).
      L[i] <- pow(p[i], yhat[i]) * pow((1 - p[i]), (1 - yhat[i]))

      # Apply zero trick in JAGS.
      phi[i] <- -log(L[i]) + cadj
      zeros[i] ~ dpois(phi[i])
    }
  }

  modelspecs <- function(nObs, u, Tmax, y, from_prior) {
    ms <- list(sigma2 = start@sigma2)
    if (!from_prior) {
      # Calculate fractional contribution `yhat`
      # based on the input data using the Kaplan-Meier method.
      yhat <- if (nObs > 0) {
        km <- survival::survfit(survival::Surv(u, y) ~ 1)
        s_tau <- tail(km$surv[km$time <= Tmax], 1) # Survival probability = S(Tmax).
        ifelse(
          u < Tmax & y == 0L, # Within the assessment window and so far no DLT.
          yes = 1 -
            s_tau / sapply(u, function(u_i) tail(km$surv[km$time <= u_i], 1)),
          no = y
        )
      } else {
        1L
      }
      ms <- c(
        list(
          skel_probs = start@skel_probs,
          zeros = rep(0, nObs),
          cadj = 1e10,
          yhat = yhat
        ),
        ms
      )
    }
    ms
  }

  .FractionalCRM(
    start,
    datamodel = datamodel,
    modelspecs = modelspecs,
    datanames = c("nObs", "xLevel")
  )
}

## default constructor ----

#' @rdname FractionalCRM-class
#' @note Typically, end users will not use the `.DefaultTITELogisticLogNormal()` function.
#' @export
.DefaultFractionalCRM <- function() {
  FractionalCRM(
    skel_probs = c(0.1, 0.2, 0.3, 0.4),
    dose_grid = c(10, 30, 50, 100),
    sigma2 = 2
  )
}

## class ----

#' `LogisticLogNormalOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`LogisticLogNormalOrdinal`] is the class for a logistic lognormal CRM model
#' using an ordinal toxicity scale.
#'
#' @aliases LogisticLogNormalOrdinal
#' @export
.LogisticLogNormalOrdinal <- setClass(
  Class = "LogisticLogNormalOrdinal",
  contains = "ModelLogNormal",
  validity = v_logisticlognormalordinal
)

## constructor ----

#' @rdname LogisticLogNormalOrdinal-class
#' @inheritParams ModelLogNormal
#' @export
#' @example examples/Model-class-LogisticLogNormalOrdinal.R
LogisticLogNormalOrdinal <- function(mean, cov, ref_dose) {
  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalOrdinal(
    params = params,
    ref_dose = positive_number(ref_dose),
    priormodel = function() {
      alpha[1] ~ dnorm(mean[1], prec[1, 1])
      for (i in 2:(k - 1)) {
        alpha[i] ~ dnorm(mean[i], prec[i, i]) %_% T(, alpha[i - 1])
      }
      gamma ~ dnorm(mean[k], prec[k, k])
      beta <- exp(gamma)
    },
    datamodel = function() {
      for (i in 1:nObs) {
        xhat[i] <- log(x[i] / ref_dose)
        for (j in 1:(k - 1)) {
          z[i, j] <- alpha[j] + beta * xhat[i]
          p[i, j] <- exp(z[i, j]) / (1 + exp(z[i, j]))
          tox[i, j] ~ dbern(p[i, j])
        }
      }
    },
    modelspecs = function(y, from_prior) {
      ms <- list(
        mean = params@mean,
        prec = params@prec,
        k = length(mean),
        tox = array(dim = c(length(y), length(mean) - 1))
      )
      if (!from_prior) {
        for (i in seq_along(y)) {
          for (j in 1:(ms$k - 1)) {
            ms$tox[i, j] <- y[i] >= j
          }
        }
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(
        alpha = sapply(1:(length(mean) - 1), function(x) -(x + 1)),
        gamma = 1
      )
    },
    datanames = c("nObs", "y", "x"),
    # Need to provide JAGS column names here
    sample = c(paste0("alpha[", 1:(length(mean) - 1), "]"), "beta")
  )
}

## default constructor ----

#' @rdname LogisticLogNormalOrdinal-class
#' @note Typically, end users will not use the `.DefaultLogisticLogNormalOrdinal()` function.
#' @export
.DefaultLogisticLogNormalOrdinal <- function() {
  LogisticLogNormalOrdinal(
    mean = c(-3, -4, 1),
    cov = diag(c(3, 4, 1)),
    ref_dose = 50
  )
}

# Generics ----

#' Obtain a Text Representation of the Reference Dose
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`GeneralModel`)\cr the model object that will be printed
#' @param ... Not used at present
#' @return A character string containing a LaTeX rendition of the model.
#' @noRd
h_knit_print_render_ref_dose <- function(x, ...) {
  UseMethod("h_knit_print_render_ref_dose")
}

#' Render a Model Function in a `knit_print` Method
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`GeneralModel`)\cr the model object that will be printed
#' @param ... Not used at present
#' @return A character string containing a LaTeX rendition of the model.
#' @noRd
h_knit_print_render_model <- function(x, ...) {
  UseMethod("h_knit_print_render_model")
}

#' Obtain a Text Representation of a Biomarker Model
#'
#' This is a helper method used `knit_print` for `DualEndpoint` classes.
#'
#' @param x (`DualEndpoint`)\cr the model object containing the biomarker model
#' @param use_values (`flag`)\cr print the values associated with hyperparameters,
#' or the symbols used to define the hyper-parameters.  That is, for example, mu or 1.
#' @param ... Not used at present
#' @return A character string containing a LaTeX rendition of the model.
#' @noRd
h_knit_print_render_biomarker_model <- function(x, use_values = TRUE, ...) {
  UseMethod("h_knit_print_render_biomarker_model")
}

# Methods ----

# DualEndpoint ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param biomarker_label (`character`)\cr A description of the biomarker
#' @rdname knit_print
#' @export
#' @method knit_print DualEndpoint
knit_print.DualEndpoint <- function(
  x,
  ...,
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f",
  units = NA,
  tox_label = "toxicity",
  biomarker_label = "PD biomarker"
) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Initialise
  biomarker_label <- h_prepare_labels(biomarker_label)
  tox_label <- h_prepare_labels(tox_label)
  units <- h_prepare_units(units)
  # Execute
  toxModel <- ProbitLogNormal(
    cov = x@betaZ_params@cov,
    mean = x@betaZ_params@mean,
    ref_dose = x@ref_dose
  )
  rv <- paste0(
    "The relationships between dose and ",
    tox_label[1],
    " and between dose and ",
    biomarker_label[1],
    " will be modelled simultaneously.\n\n",
    knit_print(
      toxModel,
      asis = asis,
      tox_label = tox_label,
      use_values = use_values,
      fmt = fmt,
      units = units,
      ...
    ),
    "\n\n",
    "The ",
    biomarker_label[1],
    " response `w` at dose `d` is modelled as ",
    "$$ w(d) \\sim N(f(d), \\sigma_w^2) $$ \n\nwhere ",
    h_knit_print_render_biomarker_model(x, use_values = use_values, ...)
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_biomarker_model.DualEndpoint <- function(
  x,
  ...,
  use_values = TRUE
) {
  "f(d) is a function of dose that is defined elsewhere."
}

# DualEndpointBeta ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_biomarker_model.DualEndpointBeta <- function(x, ...) {
  paste0(
    "f(d) is a parametric rescaled beta density function such that\n\n",
    "$$ f(d) = ",
    "E_0 + (E_{max} - E_0) \\times Beta(\\delta_1, \\delta_2) \\times ",
    "\\left(\\frac{d}{d_{max}}\\right)^{\\delta_1}  \\times \\left(1 - ",
    "\\frac{d}{d_{max}}\\right)^{\\delta_2} $$\n\n",
    "where d~max~ is the maximum dose in the dose grid, &delta;~1~ and ",
    "&delta;~2~ are the parameters of the Beta function and ",
    "E~0~ and E~max~ are, respectively, the minimum and maximum levels of the ",
    "biomarker.  The mode can be written as \n\n",
    "$$ \\text{mode} = \\frac{\\delta_1}{\\delta_1 + \\delta_2} $$\n\n",
    " and this is the parameterisation used to define the model.\n\n",
    "In this case, \n\n",
    ifelse(
      length(x@E0) == 1,
      paste0("$$ E_0 = ", x@E0, " $$\n\n)"),
      paste0("$$ E_0  \\sim U(", x@E0[1], ", ", x@E0[2], ") $$\n\n")
    ),
    ifelse(
      length(x@Emax) == 1,
      paste0("$$ E_{max} = ", x@Emax, " $$\n\n)"),
      paste0("$$ E_{max}  \\sim U(", x@Emax[1], ", ", x@Emax[2], ") $$\n\n")
    ),
    ifelse(
      length(x@delta1) == 1,
      paste0("$$ \\delta_1 = ", x@delta1, " $$\n\n)"),
      paste0(
        "$$ \\delta_1  \\sim U(",
        x@delta1[1],
        ", ",
        x@delta1[2],
        ") $$\n\n"
      )
    ),
    ifelse(
      length(x@mode) == 1,
      paste0("$$ \\text{mode} = ", x@mode, " $$\n\n)"),
      paste0(
        "$$ \\text{mode}  \\sim U(",
        x@mode[1],
        ", ",
        x@mode[2],
        ") $$\n\n"
      )
    ),
    " and \n\n",
    ifelse(
      length(x@ref_dose_beta) == 1,
      paste0("$$ d_{max} = ", x@ref_dose_beta, " $$\n\n"),
      paste0(
        "$$ d_{max}  \\sim U(",
        x@ref_dose_beta[1],
        ", ",
        x@ref_dose_beta[2],
        ") $$\n\n"
      )
    )
  )
}

# DualEndpointEmax ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_biomarker_model.DualEndpointEmax <- function(x, ...) {
  paste0(
    "f(d) is a parametric Emax density function such that\n\n",
    "$$ f(d) = ",
    "E_0 + \\frac{(E_{max} - E_0) \\times \\frac{d}{d^*}}{\\text{ED}_{50} + \\frac{d}{d^*}} $$\n\n",
    "where d* is the reference dose, E~0~ and E~max~ are, respectively, the ",
    "minimum and maximum levels of the biomarker and ED~50~ is the dose achieving ",
    "half the maximum effect, 0.5 &times; E~max~.\n\n",
    "In this case, \n\n",
    ifelse(
      length(x@E0) == 1,
      paste0("$$ E_0 = ", x@E0, " $$\n\n)"),
      paste0("$$ E_0  \\sim U(", x@E0[1], ", ", x@E0[2], ") $$\n\n")
    ),
    ifelse(
      length(x@Emax) == 1,
      paste0("$$ E_{max} = ", x@Emax, " $$\n\n)"),
      paste0("$$ E_{max}  \\sim U(", x@Emax[1], ", ", x@Emax[2], ") $$\n\n")
    ),
    ifelse(
      length(x@ED50) == 1,
      paste0("$$ \\text{ED}_{50} = ", x@ED50, " $$\n\n)"),
      paste0(
        "$$ \\text{ED}_{50}  \\sim U(",
        x@ED50[1],
        ", ",
        x@ED50[2],
        ") $$\n\n"
      )
    ),
    " and \n\n",
    ifelse(
      length(x@ref_dose_emax) == 1,
      paste0("$$ d^* = ", x@ref_dose_emax, " $$\n\n"),
      paste0(
        "$$ d^* \\sim U(",
        x@ref_dose_emax[1],
        ", ",
        x@ref_dose_emax[2],
        ") $$\n\n"
      )
    )
  )
}

# DualEndpointRW ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_biomarker_model.DualEndpointRW <- function(
  x,
  ...,
  use_values = TRUE
) {
  paste0(
    "f(d) is a ",
    ifelse(x@rw1, "first", "second"),
    " order random walk such that\n\n",
    "$$ f(d) = ",
    "\\beta_{W_i} - \\beta_{W_{i - ",
    ifelse(x@rw1, "1", "2"),
    "}}",
    "\\sim N(0, ",
    ifelse(x@rw1, "", "2 \\times "),
    ifelse(
      use_values & length(x@sigma2betaW) == 1,
      x@sigma2betaW,
      "\\sigma_{\\beta_W}^2"
    ),
    " \\times (d_i - d_{i - ",
    ifelse(x@rw1, "1", "2"),
    "})",
    ")",
    " $$\n\n",
    ifelse(
      length(x@sigma2betaW) == 1,
      ifelse(
        use_values,
        "",
        paste0(" and $\\sigma_{\\beta_W}^2$ is fixed at ", x@sigma2betaW)
      ),
      paste0(
        " and the prior for $\\sigma_{\\beta_W}^2$ is an inverse-gamma distribution with parameters ",
        "a = ",
        x@sigma2betaW["a"],
        " and b = ",
        x@sigma2betaW["b"]
      )
    )
  )
}

# ModelParamsNormal ----

#' Render a Normal Prior
#'
#' @param x (`ModelParamsNormal`)\cr the object to be rendered
#' @param use_values (`flag`)\cr print the values associated with hyperparameters,
#' or the symbols used to define the hyper-parameters.  That is, for example, mu or 1.
#' @param fmt (`character`)\cr the `sprintf` format string used to render
#' numerical values.  Ignored if `use_values` is `FALSE`.
#' @param params (`character`)\cr The names of the model parameters.  See Usage
#' Notes below.
#' @param preamble (`character`)\cr The text used to introduce the LaTeX representation
#' of the model
#' @param asis (`flag`)\cr wrap the return value in a call to `knitr::asis_output`?
#' @param theta (`character`)\cr the LaTeX representation of the theta vector
#' @param ... Not used at present
#' @section Usage Notes:
#' `params` must be a character vector of length equal to that of `x@mean` (and
#' `x@cov`).  Its values represent the parameters of the model as entries in the
#' vector `theta`, on the left-hand side of "~" in the definition of the prior.
#' If named, names should be valid LaTeX, escaped as usual for R character variables.
#' For example, `"\\alpha"` or `"\\beta_0"`.  If unnamed, names are constructed by
#' pre-pending an escaped backslash to each value provided.
#' @return A character string containing a LaTeX rendition of the object.
#' @description `r lifecycle::badge("experimental")`
#' @export
#' @rdname knit_print
#' @method knit_print ModelParamsNormal
knit_print.ModelParamsNormal <- function(
  x,
  use_values = TRUE,
  fmt = "%5.2f",
  params = c("alpha", "beta"),
  preamble = "The prior for &theta; is given by\\n",
  asis = TRUE,
  theta = "\\theta",
  ...
) {
  # Validate
  assert_class(x, "ModelParamsNormal")
  assert_format(fmt)
  assert_character(preamble, len = 1)
  assert_true(length(x@mean) == length(params))
  assert_flag(asis)
  # Initialise
  n <- length(params)
  if (is.null(names(params))) {
    names(params) <- paste0("\\", params)
  }
  # Execute
  # Construct LaTeX representation of mean vector
  mu <- sapply(
    1:n,
    function(i) {
      ifelse(
        use_values,
        sprintf(fmt, x@mean[i]),
        paste0("\\mu_{\\", params[i], "}")
      )
    }
  )
  # Construct LaTeX representation of covariance matrix
  cov <- sapply(
    1:n,
    function(i) {
      sapply(
        1:n,
        function(j) {
          ifelse(
            use_values,
            sprintf(fmt, x@cov[i, j]),
            ifelse(
              i == j,
              paste0("\\sigma_{\\", params[i], "}^2"),
              paste0(
                "\\rho\\sigma_{\\",
                params[i],
                "}\\sigma_{\\",
                params[j],
                "}"
              )
            )
          )
        }
      )
    }
  )
  # Construct LaTeX representation of prior
  rv <- paste0(
    preamble,
    "$$ \\boldsymbol",
    theta,
    " = \\begin{bmatrix}",
    paste0(names(params), collapse = " \\\\ "),
    "\\end{bmatrix}",
    "\\sim N \\left(\\begin{bmatrix}",
    paste0(mu, collapse = " \\\\ "),
    "\\end{bmatrix} , ",
    "\\begin{bmatrix} ",
    paste0(
      sapply(
        1:n,
        function(j) {
          stringr::str_trim(paste0(cov[, j], collapse = " & "))
        }
      ),
      collapse = " \\\\ "
    ),
    "\\end{bmatrix}",
    " \\right)",
    " $$\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# GeneralModel ----

#' @export
#' @rdname knit_print
#' @method knit_print GeneralModel
knit_print.GeneralModel <- function(
  x,
  ...,
  params = c("alpha", "beta"),
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f",
  units = NA
) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Execute
  rv <- paste0(
    h_knit_print_render_model(x, use_values = use_values, fmt = fmt, ...),
    knit_print(
      x@params,
      ...,
      asis = asis,
      use_values = use_values,
      fmt = fmt,
      params = params
    ),
    "\\n\\n",
    h_knit_print_render_ref_dose(
      x,
      use_values = use_values,
      fmt = fmt,
      unit = unit
    )
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @keywords internal
h_knit_print_render_ref_dose.GeneralModel <- function(
  x,
  ...,
  use_values = TRUE,
  fmt = "%5.2f",
  units = NA
) {
  # Validate
  assert_character(units, len = 1)
  # Initialise
  units <- h_prepare_units(units)
  # Execute
  ref_dose <- ifelse(
    use_values,
    paste0(
      " The reference dose will be ",
      stringr::str_trim(sprintf(fmt, x@ref_dose)),
      units,
      ".\n\n"
    ),
    ""
  )
  ref_dose
}

# LogisticKadane ----

#' @keywords internal
h_knit_print_render_ref_dose.LogisticKadane <- function(x, ...) {
  # The LogisticKadane class has no reference dose slot
  ""
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticKadane
knit_print.LogisticKadane <- function(
  x,
  ...,
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f",
  units = NA,
  tox_label = "toxicity"
) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Initialise
  tox_label <- h_prepare_labels(tox_label)
  units <- h_prepare_units(units)
  # Execute
  rv <- paste0(
    "A logistic model using the parameterisation of Kadane (1980)  will ",
    "describe the relationship between dose and ",
    tox_label[1],
    ".\n\n ",
    ifelse(
      use_values,
      paste0(
        "Let the minimum (x~min~) and maximum (x~max~) doses be ",
        paste0(stringr::str_trim(sprintf(fmt, x@xmin)), units),
        " and ",
        paste0(stringr::str_trim(sprintf(fmt, x@xmax)), units),
        ".\n\n"
      ),
      "Let x~min~ and x~max~ denote, respectively, the minimum and maximum doses.\n\n  "
    ),
    "Further, let &theta; denote the target toxicity rate and &rho;~0~ = p(DLT | D = x~min~).\n\n",
    "Let &gamma; be the dose with target toxicity rate &theta;, so that p(DLT | D = &gamma;) = &theta;",
    ifelse(
      use_values,
      paste0(" = ", x@theta, ".\n\n"),
      ".\n\n"
    ),
    "Using this parameterisation, standard logistic regression model has slope ",
    "$$ \\frac{\\gamma \\text{logit}(\\rho_0) - x_{min} \\text{logit}(\\theta)}{\\gamma - x_{min}} $$",
    " and intercept ",
    "$$ \\frac{\\text{logit}(\\theta) - logit(\\rho_0)}{\\gamma - x_{min}} $$",
    " The priors for &Gamma; and &Rho;~0~ are ",
    ifelse(
      use_values,
      paste0(
        "$$ \\Gamma \\sim U(",
        sprintf(fmt, x@xmin),
        ", ",
        sprintf(fmt, x@xmax),
        ") $$"
      ),
      "$$ \\Gamma \\sim U(x_{min}, x_{max}) $$"
    ),
    " and, independently, ",
    ifelse(
      use_values,
      paste0("$$ \\mathrm{P}_0 \\sim U(0, ", x@theta, ") $$"),
      "$$ \\mathrm{P}_0 \\sim U(0, \\theta) $$"
    ),
    "\n\n Note that x~min~ and x~max~ need not be equal to the smallest and ",
    "largest values in the `doseGrid` slot of the corresponding `Data` object.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticKadaneBetaGamma ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticKadaneBetaGamma
knit_print.LogisticKadaneBetaGamma <- function(
  x,
  ...,
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f",
  tox_label = "toxicity",
  units = NA
) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Initialise
  units <- h_prepare_units(units)
  tox_label <- h_prepare_labels(tox_label)
  # Execute
  rv <- paste0(
    "A logistic model using the parameterisation of Kadane (1980)  will ",
    "describe the relationship between dose and ",
    tox_label[1],
    ", using a Beta ",
    "distribution as the prior for &rho;~0~ and a Gamma distribution as the prior ",
    "for &gamma;.\n\n ",
    ifelse(
      use_values,
      paste0(
        "Let the minimum (x~min~) and maximum (x~max~) doses be ",
        paste0(stringr::str_trim(sprintf(fmt, x@xmin)), units),
        " and ",
        paste0(stringr::str_trim(sprintf(fmt, x@xmax)), units),
        ".\n\n"
      ),
      "Let x~min~ and x~max~ denote, respectively, the minimum and maximum doses.\n\n  "
    ),
    "Further, let &theta; denote the target toxicity rate and &rho;~0~ = p(DLT | D = x~min~).\n\n",
    "Let &gamma; be the dose with target toxicity rate &theta;, so that p(DLT | D = &gamma;) = &theta;",
    ifelse(
      use_values,
      paste0(" = ", x@theta, ".\n\n"),
      ".\n\n"
    ),
    "Using this parameterisation, standard logistic regression model has slope ",
    "$$ \\frac{\\gamma \\text{logit}(\\rho_0) - x_{min} \\text{logit}(\\theta)}{\\gamma - x_{min}} $$",
    " and intercept ",
    "$$ \\frac{\\text{logit}(\\theta) - logit(\\rho_0)}{\\gamma - x_{min}} $$",
    " The priors for &Gamma; and &Rho;~0~ are ",
    ifelse(
      use_values,
      paste0(
        "$$ \\Gamma \\sim U(",
        sprintf(fmt, x@shape),
        ", ",
        sprintf(fmt, x@rate),
        ") $$"
      ),
      "$$ \\Gamma \\sim Gamma( \\text{shape}, \\text{rate}) $$"
    ),
    " and, independently, ",
    ifelse(
      use_values,
      paste0("$$ \\mathrm{P}_0 \\sim Beta(", x@alpha, ", ", x@beta, ") $$"),
      "$$ \\mathrm{P}_0 \\sim Beta(\\alpha, \\beta) $$"
    ),
    "\n\n Note that x~min~ and x~max~ need not be equal to the smallest and ",
    "largest values in the `doseGrid` slot of the corresponding `Data` object.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticLogNormal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormal <- function(
  x,
  tox_label = "toxicity",
  ...
) {
  tox_label <- h_prepare_labels(tox_label)
  z <- "e^{\\alpha + \\beta \\cdot log(d/d_{ref})}"
  paste0(
    "A logistic log normal model will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{",
    z,
    "}{1 + ",
    z,
    "} $$\\n ",
    "where d~ref~ denotes a reference dose.\n\n"
  )
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticLogNormal
knit_print.LogisticLogNormal <- function(
  x,
  ...,
  use_values = TRUE,
  fmt = "%5.2f",
  params = c(
    "\\alpha" = "alpha",
    "log(\\beta)" = "beta"
  ),
  preamble = "The prior for &theta; is given by\\n",
  asis = TRUE
) {
  assert_flag(asis)
  # Can't use NextMethod() on a S4 class
  knit_print.GeneralModel(
    x,
    ...,
    use_values = use_values,
    fmt = fmt,
    params = params,
    preamble = preamble,
    asis = asis
  )
}

# LogisticLogNormalMixture ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormalMixture <- function(
  x,
  use_values = TRUE,
  tox_label = "toxicity",
  ...
) {
  tox_label <- h_prepare_labels(tox_label)
  z1 <- "e^{\\alpha_1 + \\beta_1 \\cdot log(d/d^*)}"
  z2 <- "e^{\\alpha_2 + \\beta_2 \\cdot log(d/d^*)}"
  pi_text <- ifelse(
    use_values,
    x@share_weight,
    "\\pi"
  )
  paste0(
    "A mixture of two logistic log normal models will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = ",
    pi_text,
    " \\times \\frac{",
    z1,
    "}{1 + ",
    z1,
    "} + (1 - ",
    pi_text,
    ") \\times \\frac{",
    z2,
    "}{1 + ",
    z2,
    "} $$",
    ifelse(
      use_values,
      "where d* denotes a reference dose.\n\n",
      "where d* denotes a reference dose and &pi; is a fixed value between 0 and 1.\n\n"
    )
  )
}

#' @export
#' @rdname knit_print
#' @method knit_print LogisticLogNormalMixture
knit_print.LogisticLogNormalMixture <- function(
  x,
  ...,
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f",
  units = NA
) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Execute
  rv <- paste0(
    h_knit_print_render_model(x, use_values = use_values, fmt = fmt, ...),
    knit_print(
      x@params,
      ...,
      asis = asis,
      use_values = use_values,
      fmt = fmt,
      preamble = "The priors for both &theta;~1~ and &theta;~2~ are given by\\n"
    ),
    "\\n\\n",
    h_knit_print_render_ref_dose(
      x,
      use_values = use_values,
      fmt = fmt,
      unit = unit
    )
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticLogNormalSub ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormalSub <- function(
  x,
  ...,
  tox_label = "toxicity"
) {
  tox_label <- h_prepare_labels(tox_label)
  z <- "e^{\\alpha + \\beta \\cdot (d \\, - \\, d^*)}"
  paste0(
    "A logistic log normal model with subtractive dose normalisation will ",
    "describe the relationship between dose and ",
    tox_label[1],
    ": \n\n",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{",
    z,
    "}{1 + ",
    z,
    "} $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticLogNormalSub
knit_print.LogisticLogNormalSub <- function(
  x,
  ...,
  use_values = TRUE,
  fmt = "%5.2f",
  params = c(
    "\\alpha" = "alpha",
    "log(\\beta)" = "beta"
  ),
  preamble = "The prior for &theta; is given by\\n",
  asis = TRUE
) {
  NextMethod(params = params)
}

# LogisticNormal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticNormal <- function(
  x,
  ...,
  tox_label = "toxicity"
) {
  tox_label <- h_prepare_labels(tox_label)
  z <- "e^{\\alpha + \\beta \\cdot d/d^*}"
  paste0(
    "A logistic log normal model will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{",
    z,
    "}{1 + ",
    z,
    "} $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

# ProbitLogNormal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.ProbitLogNormal <- function(
  x,
  tox_label = "toxicity",
  ...
) {
  tox_label <- h_prepare_labels(tox_label)
  paste0(
    "A probit log normal model will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ \\Phi^{-1}(Tox | d) = f(X = 1 | \\theta, d) = \\alpha + \\beta \\cdot log(d/d^*) $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

# ProbitLogNormalRel ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.ProbitLogNormalRel <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  assert_flag(asis)
  tox_label <- h_prepare_labels(tox_label)
  paste0(
    "A probit log normal model will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ \\Phi^{-1}(Tox | d) = f(X = 1 | \\theta, d) = \\alpha + \\beta \\cdot d/d^* $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

# LogisticNormalMixture ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticNormalMixture <- function(
  x,
  ...,
  tox_label = "toxicity"
) {
  tox_label <- h_prepare_labels(tox_label)
  z <- "e^{\\alpha + \\beta \\cdot log(d/d^*)}"
  paste0(
    "A mixture of two logistic log normal models will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{",
    z,
    "}{1 + ",
    z,
    "} $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

#' @export
#' @rdname knit_print
#' @method knit_print LogisticNormalMixture
knit_print.LogisticNormalMixture <- function(
  x,
  ...,
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f",
  units = NA
) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Execute
  rv <- paste0(
    h_knit_print_render_model(x, use_values = use_values, fmt = fmt, ...),
    "The prior for &theta; is given by\\n",
    "$$ \\theta = \\begin{bmatrix} \\alpha \\\\ log(\\beta) \\end{bmatrix}",
    " \\sim ",
    "w \\cdot ",
    knit_print(
      x@comp1,
      params = c("\\alpha" = "alpha", "\\beta" = "beta")
    ),
    " + (1 - w) \\cdot ",
    knit_print(
      x@comp2,
      params = c("\\alpha" = "alpha", "\\beta" = "beta")
    ),
    " $$\\n\\n",
    " and the prior for w is given by \n\n",
    " $$ w \\sim Beta(",
    x@weightpar[1],
    ", ",
    x@weightpar[2],
    ") $$\\n\\n",
    h_knit_print_render_ref_dose(
      x,
      units = units,
      fmt = fmt,
      use_values = use_values,
      ...
    )
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticNormalFixedMixture ----

#' @export
#' @rdname knit_print
#' @method knit_print LogisticNormalFixedMixture
knit_print.LogisticNormalFixedMixture <- function(
  x,
  ...,
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f",
  units = NA
) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Execute
  beta <- ifelse(x@log_normal, "log(\\beta)", "\\beta")
  rv <- paste0(
    h_knit_print_render_model(x, use_values = use_values, fmt = fmt, ...),
    " The prior for &theta; is given by\\n\\n",
    "$$ \\theta = \\begin{bmatrix} \\alpha \\\\ ",
    beta,
    " \\end{bmatrix}",
    " \\sim \\sum_{i=1}^{",
    length(x@components),
    "}",
    "w_i \\cdot N \\left( \\mathbf{\\mu}_i ,  \\mathbf{\\Sigma}_i \\right)",
    " $$ \\n\\n",
    " with \\n\\n",
    "$$ \\sum_{i=1}^{",
    length(x@components),
    "} w_i = 1 $$ \\n\\n",
    " The individual components of the mixture are "
  )
  if (x@log_normal) {
    params <- c("\\alpha" = "alpha", "log(\\beta)" = "beta")
  } else {
    params <- c("\\alpha" = "alpha", "\\beta" = "beta")
  }
  for (i in seq_along(x@components)) {
    comp <- x@components[[i]]
    rv <- paste0(
      rv,
      knit_print(
        comp,
        params = params,
        preamble = " ",
        use_values = use_values,
        fmt = fmt,
        theta = paste0("\\theta_", i)
      ),
      " with weight ",
      x@weights[i],
      ifelse(
        i < length(x@components),
        " and",
        " "
      )
    )
  }
  rv <- paste0(
    rv,
    " \\n\\n ",
    h_knit_print_render_ref_dose(
      x,
      units = units,
      fmt = fmt,
      use_values = use_values,
      ...
    )
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticNormalFixedMixture <- function(
  x,
  ...,
  tox_label = "toxicity"
) {
  tox_label <- h_prepare_labels(tox_label)
  z <- "e^{\\alpha + \\beta \\cdot log(d/d^*)}"
  paste0(
    "A mixture of ",
    length(x@components),
    " logistic log normal models with fixed weights will describe the relationship ",
    "between dose and ",
    tox_label[1],
    ": ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{",
    z,
    "}{1 + ",
    z,
    "} $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

# ModelLogNormal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.ModelLogNormal <- function(x, ...) {
  "The model used to characterise the dose toxicity relationship is defined in  subclasses.\n\n"
}

# OneParLogNormalPrior ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print OneParLogNormalPrior
knit_print.OneParLogNormalPrior <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE,
  use_values = TRUE,
  fmt = "%5.2f"
) {
  assert_flag(asis)

  tox_label <- h_prepare_labels(tox_label)
  s2text <- ifelse(
    use_values,
    stringr::str_trim(sprintf(fmt, x@sigma2)),
    "\\sigma^2"
  )
  rv <- paste0(
    "The relationship between dose and ",
    tox_label[1],
    " will be modelled using a version ",
    "of the one parameter CRM of O'Quigley et al (1990) with an exponential prior on the ",
    "power parameter for the skeleton prior probabilities, with",
    ifelse(
      use_values,
      paste0("$$ \\Theta \\sim Exp(", s2text, ") $$"),
      "$$ \\Theta \\sim Exp(\\lambda) $$"
    ),
    "and skeleton probabilities as in the table below.\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# OneParExpPrior ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print OneParExpPrior
knit_print.OneParExpPrior <- function(x, ..., asis = TRUE) {
  assert_flag(asis)
  rv <- "TODO\n\n"
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticLogNormalGrouped ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticLogNormalGrouped
knit_print.LogisticLogNormalGrouped <- function(
  x,
  ...,
  use_values = TRUE,
  fmt = "%5.2f",
  params = c(
    "\\alpha" = "alpha",
    "\\beta" = "beta",
    "log(\\delta_0)" = "delta_0",
    "log(\\delta_1)" = "delta_1"
  ),
  preamble = "The prior for &theta; is given by\\n",
  asis = TRUE
) {
  NextMethod(params = params)
}

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormalGrouped <- function(
  x,
  tox_label = "toxicity",
  ...
) {
  tox_label <- h_prepare_labels(tox_label)
  z <- "e^{(\\alpha + I_c \\times \\delta_0) + (\\beta  + I_c \\times \\delta_1) \\cdot log(d/d^*)}"
  paste0(
    "A logistic log normal model will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{",
    z,
    "}{1 + ",
    z,
    "} $$\\n ",
    "where d* denotes a reference dose and I~c~ is a binary indicator which ",
    "is 1 for the combo arm and 0 for the mono arm.\n\n"
  )
}

# LogisticLogNormalOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormalOrdinal <- function(x, ...) {
  z <- "e^{\\alpha_k + \\beta \\cdot log(d/d^*)}"
  paste0(
    "Let p~k~(d) be the probability that the response of a patient treated at ",
    "dose d is in category k *_or higher_*, k=0, ..., K; d=1, ..., D.\n\nThen ",
    "$$ p_k(d) = f(X \\ge k \\; | \\; \\theta, d) = \\begin{cases} 1 & k = 0 \\\\ ",
    "\\frac{",
    z,
    "}{1 + ",
    z,
    "} & k=1, ..., K",
    "\\end{cases} $$\n\n",
    "where d* denotes a reference dose.\n\nThe &alpha;s are constrained ",
    "such that &alpha;~1~ > &alpha;~2~ > ... > &alpha;~K~.\n\n"
  )
}

# LogisticLogNormalOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticLogNormalOrdinal
knit_print.LogisticLogNormalOrdinal <- function(
  x,
  ...,
  use_values = TRUE,
  fmt = "%5.2f",
  params = NA,
  preamble = "The prior for &theta; is given by\\n",
  asis = TRUE
) {
  assert_flag(asis)
  if (is.na(params)) {
    params <- c(
      paste0("alpha_", 1:(length(x@params@mean) - 1)),
      "beta"
    )
    names(params) <- paste0("\\", params)
  }
  NextMethod(params = params)
}

# LogisticIndepBeta ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticIndepBeta
knit_print.LogisticIndepBeta <- function(
  x,
  ...,
  use_values = TRUE,
  fmt = "%5.2f",
  params = NA,
  tox_label = "DLAE",
  preamble = "The prior for &theta; is given by\\n",
  asis = TRUE
) {
  assert_flag(asis)

  tox_label <- h_prepare_labels(tox_label)
  y <- tidy(x)
  z <- "e^{\\phi_1 + \\phi_2 \\cdot log(d)}"
  posterior <- ModelParamsNormal(mean = c(x@phi1, x@phi2), cov = x@Pcov)
  # knit_print.ModelParamsNormal expects no row or column names
  rownames(posterior@cov) <- NULL
  colnames(posterior@cov) <- NULL

  rv <- paste0(
    "A logistic log normal model will describe the relationship between dose and ",
    tox_label[1],
    ": ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{",
    z,
    "}{1 + ",
    z,
    "} $$\\n ",
    "The prior is expressed in terms of pseudo data and, consequently, the number ",
    " of cases and of ",
    tox_label[2],
    " need not be whole numbers.\n\nThe pseudo data are ",
    "defined in the following table:\n\n",
    paste0(
      do.call(
        function(x) {
          kableExtra::kable_styling(
            knitr::kable(x, col.names = c("Dose", "N", tox_label[2])),
            bootstrap_options = c("striped", "hover", "condensed")
          )
        },
        list(x = y$pseudoData)
      ),
      collapse = "\n"
    ),
    ifelse(
      nrow(y$data) == 0,
      "\n\nNo observed data has yet been recorded.\n",
      paste(
        "\n\nThe observed data are given in the following table:\n\n",
        paste((do.call(knitr::kable, list(x = y$data))), collapse = "\n")
      )
    ),
    knit_print(
      posterior,
      preamble = paste0(
        "\n\nTogether, the pseudo and observed data give rise to ",
        "the following posterior for the model parameters:\n\n"
      ),
      params = c("\\phi_1" = "phi1", "\\phi_2" = "phi2"),
      theta = "\\phi",
      asis = FALSE,
      ...
    ),
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# Effloglog ----

#' @description `r lifecycle::badge("experimental")`
#' @param eff_label (`character`)\cr the term used to describe efficacy
#' @rdname knit_print
#' @export
#' @method knit_print Effloglog
knit_print.Effloglog <- function(
  x,
  ...,
  use_values = TRUE,
  fmt = "%5.2f",
  params = NA,
  tox_label = "DLAE",
  eff_label = "efficacy",
  label = "participant",
  preamble = "The prior for &theta; is given by\\n",
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(eff_label, len = 1, any.missing = FALSE)

  # Prepare
  tox_label <- h_prepare_labels(tox_label)
  eff_label <- h_prepare_labels(eff_label)
  label <- h_prepare_labels(label)

  y <- tidy(x)
  # knit_print.ModelParamsNormal expects no row or column names
  posterior <- ModelParamsNormal(mean = c(x@theta1, x@theta2), cov = x@Q)
  rownames(posterior@cov) <- NULL
  colnames(posterior@cov) <- NULL

  rv <- paste0(
    "A linear log-log model with a pseudo data prior will describe the ",
    "relationship between dose and ",
    eff_label[1],
    ".  The model is given by\n ",
    "$$ y_i = \\theta_1 + \\theta_2 \\cdot \\log(\\log(d_i + k)) + \\epsilon_i $$\\n ",
    "where k is a constant (equal to ",
    x@const,
    "), y~i~ is the ",
    eff_label[1],
    " response for ",
    label[1],
    " i, treated at dose d~i~ and &epsilon;~i~ is an error term.  ",
    "The &epsilon;s are iid N(0, &nu;^-1^).\n\n  ",
    "The ",
    ifelse(
      length(x@nu) == 1,
      paste0(
        ifelse(nrow(y$data) == 0, "prior", "posterior"),
        " value of &nu; is ",
        x@nu,
        "."
      ),
      paste0(
        ifelse(nrow(y$data) == 0, "prior", "posterior"),
        " distribution of &nu; is currently &Gamma;(",
        sprintf(fmt, x@nu[1]),
        ", ",
        sprintf(fmt, x@nu[2]),
        ")."
      )
    ),
    "\n\nThe joint distribution of ",
    "&theta;~1~ and &theta;~2~ is given by\n\n",
    "$$ \\boldsymbol\\theta = \\begin{bmatrix}\\theta_1 \\\\ \\theta_2\\end{bmatrix} ",
    "\\sim N\\left(\\mu, \\nu \\boldsymbol{Q}^\\intercal \\right) $$ \nwhere ",
    "$\\boldsymbol{Q} = \\boldsymbol{X_0}^\\intercal\\boldsymbol{X_0} + ",
    "\\boldsymbol{X}^\\intercal\\boldsymbol{X}$ and **X~0~** is a design matrix ",
    "based on the dose levels in the pseudo data and **X** is a design matrix ",
    "based on the dose levels of ",
    label[2],
    "' no-",
    tox_label[1],
    " ",
    eff_label[1],
    " responses in the observed data, if any.\n\n",
    ifelse(
      nrow(y$data) == 0,
      "\n\nNo observed data has yet been recorded.\n",
      paste(
        "\n\nThe data observed to date are given in the following table:\n\n",
        paste(
          (do.call(
            function(z) {
              z %>%
                dplyr::select(-c(NObs, NGrid, DoseGrid, XLevel)) %>%
                knitr::kable() %>%
                kableExtra::kable_styling(
                  bootstrap_options = c("striped", "hover", "condensed")
                )
            },
            list(z = y$data)
          )),
          collapse = "\n"
        )
      )
    ),
    knit_print(
      posterior,
      preamble = paste0(
        "\n\nTogether, the pseudo and observed data give rise to ",
        "the following posterior for the model parameters:\n\n"
      ),
      params = c("\\theta_1" = "theta1", "\\theta_2" = "theta2"),
      asis = FALSE,
      ...
    ),
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @include helpers.R
#' @include helpers_covr.R
#' @include logger.R
#' @include Samples-class.R
NULL

# mcmc ----

#' Obtaining Posterior Samples for all Model Parameters
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is the function that actually runs the `JAGS` MCMC machinery to produce
#' posterior samples from all model parameters and required derived values.
#' It is a generic function, so that customized versions may be conveniently
#' defined for specific subclasses of [`GeneralData`], [`GeneralModel`], and
#' [`McmcOptions`] input.
#'
#' @note The type of Random Number Generator (RNG) and its initial seed used by
#'   `JAGS` are taken from the `options` argument. If no initial values are
#'   supplied (i.e RNG kind or seed slot in `options` has `NA`), then they will
#'   be generated automatically by `JAGS`.
#'
#' @param data (`GeneralData`)\cr an input data.
#' @param model (`GeneralModel`)\cr an input model.
#' @param options (`McmcOptions`)\cr MCMC options.
#' @param ... not used.
#'
#' @return The posterior samples, an object of class [`Samples`].
#' @export
#'
setGeneric(
  name = "mcmc",
  def = function(data, model, options, ...) {
    standardGeneric("mcmc")
  },
  valueClass = "Samples"
)

# mcmc-GeneralData ----

#' @describeIn mcmc Standard method which uses JAGS.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData
#' @example examples/mcmc.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "GeneralModel",
    options = "McmcOptions"
  ),
  def = function(data, model, options, from_prior = data@nObs == 0L, ...) {
    assert_flag(from_prior)

    model_fun <- if (from_prior) {
      model@priormodel
    } else {
      h_jags_join_models(model@datamodel, model@priormodel)
    }

    model_file <- h_jags_write_model(model_fun)
    model_inits <- h_jags_get_model_inits(model, data)
    model_data <- h_jags_get_data(model, data, from_prior)

    jags_model <- rjags::jags.model(
      file = model_file,
      data = model_data,
      inits = c(
        model_inits,
        .RNG.name = h_null_if_na(options@rng_kind),
        .RNG.seed = h_null_if_na(options@rng_seed)
      ),
      quiet = !is_logging_enabled(),
      n.adapt = 0 # No adaptation. Important for reproducibility.
    )
    update(jags_model, n.iter = options@burnin, progress.bar = "none")

    # This is necessary as some outputs are written directly from the JAGS
    # compiled code to the outstream.
    log_trace("Running rjags::jags.samples")
    if (is_logging_enabled()) {
      jags_samples <- rjags::jags.samples(
        model = jags_model,
        variable.names = model@sample,
        n.iter = (options@iterations - options@burnin),
        thin = options@step
      )
    } else {
      invisible(
        capture.output(
          jags_samples <- rjags::jags.samples(
            model = jags_model,
            variable.names = model@sample,
            n.iter = (options@iterations - options@burnin),
            thin = options@step,
            progress.bar = "none"
          )
        )
      )
    }
    log_trace("JAGS samples: ", jags_samples, capture = TRUE)
    samples <- lapply(jags_samples, h_jags_extract_samples)

    Samples(data = samples, options = options)
  }
)

# mcmc-GeneralData-DualEndpointRW ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`DualEndpointRW`] model, it is required that there are at least two (in
#'   case of random walk prior of the first order on the biomarker level) or
#'   three doses in the grid.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-DualEndpointRW
#' @example examples/mcmc-DualEndpointRW.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "DualEndpointRW",
    options = "McmcOptions"
  ),
  def = function(data, model, options, from_prior = data@nObs == 0L, ...) {
    if (model@rw1) {
      assert_true(data@nGrid >= 2)
    } else {
      assert_true(data@nGrid >= 3)
    }

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-DualEndpointBeta ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`DualEndpointBeta`] model, it is required that the value of `ref_dose_beta`
#'   slot is greater than the maximum dose in a grid. This requirement comes from
#'   definition of the beta function that is used to model dose-biomarker
#'   relationship in [`DualEndpointBeta`] model. The other requirement is that
#'   there must be at least one dose in the grid.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-DualEndpointBeta
#' @example examples/mcmc-DualEndpointBeta.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "DualEndpointBeta",
    options = "McmcOptions"
  ),
  def = function(data, model, options, from_prior = data@nObs == 0L, ...) {
    assert_true(data@nGrid >= 1)
    assert_true(model@ref_dose_beta > data@doseGrid[data@nGrid])

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-DualEndpointEmax ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`DualEndpointEmax`] model, it is required that there is at least one dose
#'   in the grid.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-DualEndpointEmax
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "DualEndpointEmax",
    options = "McmcOptions"
  ),
  def = function(data, model, options, from_prior = data@nObs == 0L, ...) {
    assert_true(data@nGrid >= 1)

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-OneParLogNormalPrior ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`OneParLogNormalPrior`] model, it is required that the length of
#'   skeleton prior probabilities vector should be equal to the length of the
#'   number of doses.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-OneParLogNormalPrior
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "OneParLogNormalPrior",
    options = "McmcOptions"
  ),
  def = function(data, model, options, from_prior = data@nObs == 0L, ...) {
    if (!from_prior) {
      assert_true(length(model@skel_probs) == data@nGrid)
    }

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-OneParExpPrior ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`OneParExpPrior`] model, it is required that the length of
#'   skeleton prior probabilities vector should be equal to the length of the
#'   number of doses.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-OneParExpPrior
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "OneParExpPrior",
    options = "McmcOptions"
  ),
  def = function(data, model, options, from_prior = data@nObs == 0L, ...) {
    if (!from_prior) {
      assert_true(length(model@skel_probs) == data@nGrid)
    }

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# nolint start

## --------------------------------------------------
## The method for DataMixture usage
## --------------------------------------------------

##' @describeIn mcmc Method for DataMixture with different from_prior default
setMethod(
  "mcmc",
  signature = signature(
    data = "DataMixture",
    model = "GeneralModel",
    options = "McmcOptions"
  ),
  def = function(
    data,
    model,
    options,
    from_prior = data@nObs == 0L & data@nObsshare == 0L,
    ...
  ) {
    callNextMethod(data, model, options, from_prior = from_prior, ...)
  }
)


## --------------------------------------------------
## Replacement for BayesLogit::logit
## --------------------------------------------------

#' Do MCMC sampling for Bayesian logistic regression model
#'
#' @param y 0/1 vector of responses
#' @param X design matrix
#' @param m0 prior mean vector
#' @param P0 precision matrix
#' @param options McmcOptions object
#'
#' @importFrom rjags jags.model jags.samples
#' @return the matrix of samples (samples x parameters)
#' @keywords internal
myBayesLogit <- function(y, X, m0, P0, options) {
  ## assertions
  p <- length(m0)
  nObs <- length(y)
  stopifnot(
    is.vector(y),
    all(y %in% c(0, 1)),
    is.matrix(P0),
    identical(dim(P0), c(p, p)),
    is.matrix(X),
    identical(dim(X), c(nObs, p)),
    is(options, "McmcOptions")
  )

  ## get or set the seed
  rSeed <- try(get(".Random.seed", envir = .GlobalEnv), silent = TRUE)
  if (is(rSeed, "try-error")) {
    set.seed(floor(runif(n = 1, min = 0, max = 1e4)))
    rSeed <- get(".Random.seed", envir = .GlobalEnv)
  }
  ## .Random.seed contains two leading integers where the second
  ## gives the position in the following 624 long vector (see
  ## ?set.seed). Take the current position and ensure positivity
  rSeed <- abs(rSeed[-c(1:2)][rSeed[2]])

  ## build the model according to whether we sample from prior
  ## or not:
  bugsModel <- function() {
    for (i in 1:nObs) {
      y[i] ~ dbern(p[i])
      logit(p[i]) <- mu[i]
    }

    mu <- X[,] %*% beta

    ## the multivariate normal prior on the coefficients
    beta ~ dmnorm(priorMean[], priorPrec[,])
  }

  ## write the model file into it
  modelFileName <- h_jags_write_model(bugsModel)

  jagsModel <- rjags::jags.model(
    modelFileName,
    data = list(
      "X" = X,
      "y" = y,
      "nObs" = nObs,
      priorMean = m0,
      priorPrec = P0
    ),
    quiet = TRUE,
    ## add the RNG seed to the inits list:
    ## (use Mersenne Twister as per R
    ## default)
    inits = list(
      .RNG.name = "base::Mersenne-Twister",
      .RNG.seed = rSeed
    ),
    n.chains = 1,
    n.adapt = 0
  )
  ## burn in
  update(jagsModel, n.iter = options@burnin, progress.bar = "none")

  ## samples
  samplesCode <- "samples <-
    rjags::jags.samples(model=jagsModel,
                        variable.names='beta',
                        n.iter=
                          (options@iterations - options@burnin),
                        thin=options@step,
                        progress.bar='none')"

  ## this is necessary because some outputs
  ## are written directly from the JAGS compiled
  ## code to the outstream
  capture.output(eval(parse(text = samplesCode)))

  return(t(samples$beta[,, 1L]))
}


## ----------------------------------------------------------------------------------
## Obtain posterior samples for the two-parameter logistic pseudo DLE model
## -------------------------------------------------------------------------------

##' @describeIn mcmc Obtain posterior samples for the model parameters based on the pseudo 'LogisticsIndepBeta'
##' DLE model. The joint prior and posterior probability density function of
##' the intercept \eqn{\phi_1} (phi1) and the slope \eqn{\phi_2} (phi2) are given in Whitehead and
##' Williamson (1998) and TsuTakawa (1975). However, since asymptotically, the joint posterior probability density
##' will be bivariate normal and we will use the bivariate normal distribution to
##' generate posterior samples of the intercept and the slope parameters. For the prior samples of
##' of the intercept and the slope a bivariate normal distribution with mean and the covariance matrix given in Whitehead and
##' Williamson (1998) is used.
##'
##' @importFrom mvtnorm rmvnorm
##' @example examples/mcmc-LogisticIndepBeta.R
setMethod(
  "mcmc",
  signature = signature(
    data = "Data",
    model = "LogisticIndepBeta",
    options = "McmcOptions"
  ),
  def = function(data, model, options, ...) {
    ## update the DLE model first
    thismodel <- update(object = model, data = data)

    ## decide whether we sample from the prior or not
    from_prior <- data@nObs == 0L

    ## probabilities of risk of DLE at all dose levels
    pi <- (thismodel@binDLE) / (thismodel@DLEweights)
    ## scalar term for the covariance matrix
    scalarI <- thismodel@DLEweights * pi * (1 - pi)
    ##
    precision <- matrix(rep(0, 4), nrow = 2, ncol = 2)

    for (i in (1:(length(thismodel@binDLE)))) {
      precisionmat <- scalarI[i] *
        matrix(
          c(
            1,
            log(thismodel@DLEdose[i]),
            log(thismodel@DLEdose[i]),
            (log(thismodel@DLEdose[i]))^2
          ),
          2,
          2
        )
      precision <- precision + precisionmat
    }

    if (from_prior) {
      ## sample from the (asymptotic) bivariate normal prior for theta

      tmp <- mvtnorm::rmvnorm(
        n = size(options),
        mean = c(slot(thismodel, "phi1"), slot(thismodel, "phi2")),
        sigma = solve(precision)
      )

      samples <- list(
        phi1 = tmp[, 1],
        phi2 = tmp[, 2]
      )
    } else {
      weights <- rep(1, length(data@y))
      ## probabilities of risk of DLE at all dose levels
      pi <- (data@y) / weights
      ## scalar term for the covariance matrix
      scalarI <- weights * pi * (1 - pi)
      ##

      priordle <- thismodel@binDLE
      priorw1 <- thismodel@DLEweights

      priordose <- thismodel@DLEdose
      FitDLE <- suppressWarnings(glm(
        priordle / priorw1 ~ log(priordose),
        family = binomial(link = "logit"),
        weights = priorw1
      ))
      SFitDLE <- summary(FitDLE)
      ## Obtain parameter estimates for dose-DLE curve
      priorphi1 <- coef(SFitDLE)[1, 1]
      priorphi2 <- coef(SFitDLE)[2, 1]

      ## use fast special sampler here
      ## set up design matrix
      X <- cbind(1, log(data@x))
      initRes <- myBayesLogit(
        y = data@y,
        X = X,
        m0 = c(priorphi1, priorphi2),
        P0 = precision,
        options = options
      )

      ## then form the samples list
      samples <- list(
        phi1 = initRes[, 1],
        phi2 = initRes[, 2]
      )
    }

    ## form a Samples object for return:
    ret <- Samples(
      data = samples,
      options = options
    )

    return(ret)
  }
)

## ================================================================================

## -----------------------------------------------------------------------------------
## obtain the posterior samples for the Pseudo Efficacy log log model
## ----------------------------------------------------------------------------
##
##' @describeIn mcmc Obtain the posterior samples for the model parameters in the
##' Efficacy log log model. Given the value of \eqn{\nu}, the precision of the efficacy responses,
##' the joint prior or the posterior probability of the intercept \eqn{\theta_1} (theta1) and
##' the slope \eqn{\theta_2} (theta2) is a bivariate normal distribution. The  \eqn{\nu} (nu),
##' the precision of the efficacy responses is either a fixed value or has a gamma distribution.
##' If a gamma distribution is used, the samples of nu will be first generated.
##' Then the mean of the of the nu samples
##' will be used the generate samples of the intercept and slope parameters of the model
##' @example examples/mcmc-Effloglog.R
##' @importFrom mvtnorm rmvnorm
setMethod(
  f = "mcmc",
  signature = signature(
    data = "DataDual",
    model = "Effloglog",
    options = "McmcOptions"
  ),
  definition = function(data, model, options, ...) {
    model <- update(object = model, data = data)
    sample_size <- size(options)

    if (model@use_fixed) {
      nu <- model@nu
      nu_samples <- rep(nu, sample_size)
    } else {
      nu_samples <- rgamma(
        sample_size,
        shape = model@nu["a"],
        rate = model@nu["b"]
      )
      nu <- mean(nu_samples)
    }

    # Sample from the (asymptotic) bivariate normal prior for theta1 and theta2.
    tmp <- mvtnorm::rmvnorm(
      n = sample_size,
      mean = model@mu,
      sigma = solve(nu * model@Q)
    )

    samples <- list(
      theta1 = tmp[, 1],
      theta2 = tmp[, 2],
      nu = nu_samples
    )

    Samples(
      data = samples,
      options = options
    )
  }
)
## ======================================================================================
## -----------------------------------------------------------------------------------
## obtain the posterior samples for the Pseudo Efficacy Flexible form
## ----------------------------------------------------------------------------
##
##' @describeIn mcmc Obtain the posterior samples for the estimates in the Efficacy Flexible form.
##' This is the mcmc procedure based on what is described in Lang and Brezger (2004) such that
##' samples of the mean efficacy responses at all dose levels, samples of sigma2 \eqn{sigma^2},
##' the variance of the efficacy response and samples of sigma2betaW \eqn{sigma^2_{beta_W}}, the variance of
##' the random walk model will
##' be generated. Please refer to Lang and Brezger (2004) for the procedures and the form of
##' the joint prior and posterior probability density for the mean efficacy responses. In addition,
##' both sigma2 and sigma2betaW can be fixed or having an inverse-gamma prior and posterior distribution.
##' Therefore, if the inverse gamma distribution(s) are used, the parameters in the distribution will be
##' first updated and then samples of sigma2 and sigma2betaW will be generated using the updated parameters.
##' @example examples/mcmc-EffFlexi.R
setMethod(
  "mcmc",
  signature = signature(
    data = "DataDual",
    model = "EffFlexi",
    options = "McmcOptions"
  ),
  def = function(data, model, options, ...) {
    ## update the model
    thismodel <- update(object = model, data = data)

    nSamples <- size(options)

    ## Prepare samples container
    ### List parameter samples to save
    samples <- list(
      ExpEff = matrix(ncol = data@nGrid, nrow = nSamples),
      sigma2W = matrix(nrow = nSamples),
      sigma2betaW = matrix(nrow = nSamples)
    )
    ## Prepare starting values
    ## Index of the next sample to be saved:

    iterSave <- 1L
    ## Monitoring the Metropolis-Hastings update for sigma2

    acceptHistory <- list(sigma2W = logical(options@iterations))

    ## Current parameter values and also the starting values for the MCMC are set
    ## EstEff: constant, the average of the observed efficacy values

    if (length(data@w) == 0) {
      w1 <- thismodel@eff
      x1 <- thismodel@eff_dose
    } else {
      ## Combine pseudo data with observed efficacy responses and no DLT observed
      eff_obsrv <- getEff(data, no_dlt = TRUE)
      w1 <- c(thismodel@eff, eff_obsrv$w_no_dlt)
      x1 <- c(thismodel@eff_dose, eff_obsrv$x_no_dlt)
    }
    x1Level <- match_within_tolerance(x1, data@doseGrid)
    ## betaW is constant, the average of the efficacy values
    betaW <- rep(mean(w1), data@nGrid)
    ## sigma2betaW use fixed value or prior mean
    sigma2betaW <-
      if (thismodel@use_fixed[["sigma2betaW"]]) {
        thismodel@sigma2betaW
      } else {
        thismodel@sigma2betaW["b"] / (thismodel@sigma2betaW["a"] - 1)
      }
    ## sigma2: fixed value or just the empirical variance
    sigma2W <- if (thismodel@use_fixed[["sigma2W"]]) {
      thismodel@sigma2W
    } else {
      var(w1)
    }
    ## Set up diagonal matrix with the number of patients in the corresponding dose levels on the diagonal
    designWcrossprod <- crossprod(thismodel@X)

    ### The MCMC cycle

    for (iterMcmc in seq_len(options@iterations)) {
      ## 1) Generate coefficients for the Flexible Efficacy model
      ## the variance
      adjustedVar <- sigma2W
      ## New precision matrix
      thisPrecW <- designWcrossprod / adjustedVar + thismodel@RW / sigma2betaW
      ## draw random normal vector
      normVec <- rnorm(data@nGrid)
      ## and its Cholesky factor
      thisPrecWchol <- chol(thisPrecW)
      ## solve betaW for L^T * betaW = normVec
      betaW <- backsolve(r = thisPrecWchol, x = normVec)
      ## the residual
      adjustedW <- w1 - thismodel@X %*% betaW

      ## forward substitution
      ## solve L^T * tmp = designW ^T * adjustedW/ adjustedVar

      tmp <- forwardsolve(
        l = thisPrecWchol,
        x = crossprod(thismodel@X, adjustedW) / adjustedVar,
        upper.tri = TRUE,
        transpose = TRUE
      )
      ## Backward substitution solve R*tepNew =tmp
      tmp <- backsolve(
        r = thisPrecWchol,
        x = tmp
      )

      ## tmp is the mean vector of the distribution
      ## add tmp to betaW to obtain final sample

      betaW <- betaW + tmp

      ## 2) Generate prior variance factor for the random walk
      ## if fixed, do nothing
      ## Otherwise sample from full condition

      if (!thismodel@use_fixed[["sigma2betaW"]]) {
        sigma2betaW <- rinvGamma(
          n = 1L,
          a = thismodel@sigma2betaW["a"] + thismodel@RW_rank / 2,
          b = thismodel@sigma2betaW["b"] +
            crossprod(betaW, thismodel@RW %*% betaW) / 2
        )
      }
      ## 3) Generate variance for the flexible efficacy model
      ## if fixed variance is used
      if (thismodel@use_fixed[["sigma2W"]]) {
        ## do nothing
        acceptHistory$sigma2W[iterMcmc] <- TRUE
      } else {
        ## Metropolis-Hastings update step here, using
        ## an inverse gamma distribution
        aStar <- thismodel@sigma2W["a"] + length(x1) / 2
        ## Second parameter bStar depends on the value for sigma2W
        bStar <- function(x) {
          adjW <- w1
          ret <- sum((adjW - betaW[x1Level])^2) / 2 + thismodel@sigma2W["b"]
          return(ret)
        }
        ### Draw proposal:
        bStarProposal <- bStar(sigma2W)
        sigma2W <- rinvGamma(n = 1L, a = aStar, b = bStarProposal)
      }

      ## 4)Save Samples

      if (saveSample(options, iterMcmc)) {
        samples$ExpEff[iterSave, ] <- betaW
        samples$sigma2W[iterSave, 1] <- sigma2W
        samples$sigma2betaW[iterSave, 1] <- sigma2betaW
        iterSave <- iterSave + 1L
      }
    }

    ret <- Samples(
      data = samples,
      options = options
    )
    return(ret)
  }
)
# nolint end

## -----------------------------------------------------------------------------------
## obtain the posterior samples for ordinal models
## ----------------------------------------------------------------------------
##
##' @describeIn mcmc Obtain the posterior samples for the model parameters in the
##' `LogisticLogNormalOrdinal`.
##'
##' The generic `mcmc` method returns a `Samples` object with elements of the
##' `data` slot named `alpha[1]`, `alpha[2]`, ..., `alpha[k]` and `beta` when
##' passed a `LogisticLogNormalOrdinal` object.  This makes the "alpha elements"
##' awkward to access and is inconsistent with other `Model` objects.  So rename
##' the alpha elements to `alpha1`, `alpha2`, ..., `alpha<k>` for ease and
##' consistency.
##'
##' @example examples/mcmc-LogisticLogNormalOrdinal.R
setMethod(
  f = "mcmc",
  signature = signature(
    data = "DataOrdinal",
    model = "LogisticLogNormalOrdinal",
    options = "McmcOptions"
  ),
  definition = function(data, model, options, ...) {
    # Obtain samples using the default method, but ...
    return_value <- callNextMethod()
    # ... rename the alpha elements from alpha[<k>] to alpha<k>, where <k> is an
    # integer
    names(return_value@data) <- gsub(
      "\\[(\\d+)\\]",
      "\\1",
      names(return_value@data)
    )
    return_value
  }
)

##' @include helpers.R
##' @include Model-class.R
NULL

# nolint start

##' Convert prior quantiles (lower, median, upper) to logistic (log)
##' normal model
##'
##' This function uses generalized simulated annealing to optimize
##' a \code{\linkS4class{LogisticNormal}} model to be as close as possible
##' to the given prior quantiles.
##'
##' @param dosegrid the dose grid
##' @param refDose the reference dose
##' @param lower the lower quantiles
##' @param median the medians
##' @param upper the upper quantiles
##' @param level the credible level of the (lower, upper) intervals (default:
##' 0.95)
##' @param logNormal use the log-normal prior? (not default) otherwise, the
##' normal prior for the logistic regression coefficients is used
##' @param parstart starting values for the parameters. By default, these
##' are determined from the medians supplied.
##' @param parlower lower bounds on the parameters (intercept alpha and the
##' slope beta, the corresponding standard deviations and the correlation.)
##' @param parupper upper bounds on the parameters
##' @param seed seed for random number generation
##' @param verbose be verbose? (default)
##' @param control additional options for the optimisation routine, see
##' \code{\link[GenSA]{GenSA}} for more details
##' @return a list with the best approximating \code{model}
##' (\code{\linkS4class{LogisticNormal}} or
##' \code{\linkS4class{LogisticLogNormal}}), the resulting \code{quantiles}, the
##' \code{required} quantiles and the \code{distance} to the required quantiles,
##' as well as the final \code{parameters} (which could be used for running the
##' algorithm a second time)
##'
##' @importFrom GenSA GenSA
##' @importFrom mvtnorm rmvnorm
##' @export
##' @keywords programming
Quantiles2LogisticNormal <- function(
  dosegrid,
  refDose,
  lower,
  median,
  upper,
  level = 0.95,
  logNormal = FALSE,
  parstart = NULL,
  parlower = c(-10, -10, 0, 0, -0.95),
  parupper = c(10, 10, 10, 10, 0.95),
  seed = 12345,
  verbose = TRUE,
  control = list(
    threshold.stop = 0.01,
    maxit = 50000,
    temperature = 50000,
    max.time = 600
  )
) {
  ## extracts and checks
  nDoses <- length(dosegrid)

  assert_flag(logNormal)
  assert_flag(verbose)
  assert_probability(level, bounds_closed = FALSE)
  stopifnot(
    !is.unsorted(dosegrid, strictly = TRUE),
    ## the medians must be monotonically increasing:
    !is.unsorted(median),
    identical(length(lower), nDoses),
    identical(length(median), nDoses),
    identical(length(upper), nDoses),
    all(lower < median),
    all(upper > median),
    identical(length(parlower), 5L),
    identical(length(parupper), 5L),
    all(parlower < parstart),
    all(parstart < parupper)
  )

  ## put verbose argument in the control list
  control$verbose <- verbose

  ## parametrize in terms of the means for the intercept alpha and the
  ## (log) slope beta,
  ## the corresponding standard deviations and the correlation.
  ## Define start values for optimisation:
  startValues <-
    if (is.null(parstart)) {
      ## find approximate means for alpha and slope beta
      ## from fitting logistic model to medians:
      startAlphaBeta <-
        coef(lm(I(logit(median)) ~ I(log(dosegrid / refDose))))

      ## overall starting values:
      c(
        meanAlpha = startAlphaBeta[1],
        meanBeta = if (logNormal) log(startAlphaBeta[2]) else startAlphaBeta[2],
        sdAlpha = 1,
        sdBeta = 1,
        correlation = 0
      )
    } else {
      parstart
    }

  ## what is the target function which we want to minimize?
  target <- function(param) {
    ## form the mean vector and covariance matrix
    mean <- param[1:2]
    cov <- matrix(
      c(
        param[3]^2,
        prod(param[3:5]),
        prod(param[3:5]),
        param[4]^2
      ),
      nrow = 2L,
      ncol = 2L
    )

    ## simulate from the corresponding normal distribution
    set.seed(seed)
    normalSamples <- mvtnorm::rmvnorm(
      n = 1e4L,
      mean = mean,
      sigma = cov
    )

    ## extract separate coefficients
    alphaSamples <- normalSamples[, 1L]
    betaSamples <- if (logNormal) {
      exp(normalSamples[, 2L])
    } else {
      normalSamples[, 2L]
    }

    ## and compute resulting quantiles
    quants <- matrix(
      nrow = length(dosegrid),
      ncol = 3L
    )
    colnames(quants) <- c("lower", "median", "upper")

    ## process each dose after another:
    for (i in seq_along(dosegrid)) {
      ## create samples of the probability
      probSamples <-
        plogis(alphaSamples + betaSamples * log(dosegrid[i] / refDose))

      ## compute lower, median and upper quantile
      quants[i, ] <-
        quantile(probSamples, probs = c((1 - level) / 2, 0.5, (1 + level) / 2))
    }

    ## now we can compute the target value
    ret <- max(abs(quants - c(lower, median, upper)))
    return(structure(ret, mean = mean, cov = cov, quantiles = quants))
  }

  set.seed(seed)
  ## now optimise the target
  genSAres <- GenSA::GenSA(
    par = startValues,
    fn = target,
    lower = parlower,
    upper = parupper,
    control = control
  )
  distance <- genSAres$value
  pars <- genSAres$par
  targetRes <- target(pars)

  ## and construct the model
  ret <-
    if (logNormal) {
      LogisticLogNormal(
        mean = attr(targetRes, "mean"),
        cov = attr(targetRes, "cov"),
        ref_dose = refDose
      )
    } else {
      LogisticNormal(
        mean = attr(targetRes, "mean"),
        cov = attr(targetRes, "cov"),
        ref_dose = refDose
      )
    }

  ## return it together with the resulting distance and the quantiles
  return(list(
    model = ret,
    parameters = pars,
    quantiles = attr(targetRes, "quantiles"),
    required = cbind(lower, median, upper),
    distance = distance
  ))
}

# nolint end

#' Helper for Minimal Informative Unimodal Beta Distribution
#'
#' As defined in Neuenschwander et al (2008), this function computes the
#' parameters of the minimal informative unimodal beta distribution, given the
#' request that the p-quantile should be q, i.e. `X ~ Be(a, b)` with
#' `Pr(X <= q) = p`.
#'
#' @param p (`number`)\cr the probability.
#' @param q (`number`)\cr the quantile.
#' @return A list with the two resulting beta parameters `a` and `b`.
#'
#' @keywords internal
h_get_min_inf_beta <- function(p, q) {
  assert_probability(p, bounds_closed = FALSE)
  assert_probability(q, bounds_closed = FALSE)

  if (q > p) {
    list(
      a = log(p) / log(q),
      b = 1
    )
  } else {
    list(
      a = 1,
      b = log(1 - p) / log(1 - q)
    )
  }
}

# nolint start

##' Construct a minimally informative prior
##'
##' This function constructs a minimally informative prior, which is captured in
##' a \code{\linkS4class{LogisticNormal}} (or
##' \code{\linkS4class{LogisticLogNormal}}) object.
##'
##' Based on the proposal by Neuenschwander et al (2008, Statistics in
##' Medicine), a minimally informative prior distribution is constructed. The
##' required key input is the minimum (\eqn{d_{1}} in the notation of the
##' Appendix A.1 of that paper) and the maximum value (\eqn{d_{J}}) of the dose
##' grid supplied to this function. Then \code{threshmin} is the probability
##' threshold \eqn{q_{1}}, such that any probability of DLT larger than
##' \eqn{q_{1}} has only 5% probability. Therefore \eqn{q_{1}} is the 95%
##' quantile of the beta distribution and hence \eqn{p_{1} = 0.95}. Likewise,
##' \code{threshmax} is the probability threshold \eqn{q_{J}}, such that any
##' probability of DLT smaller than \eqn{q_{J}} has only 5% probability
##' (\eqn{p_{J} = 0.05}). The probabilities \eqn{1 - p_{1}} and \eqn{p_{J}} can be
##' controlled with the arguments \code{probmin} and \code{probmax}, respectively.
##' Subsequently, for all doses supplied in the
##' \code{dosegrid} argument, beta distributions are set up from the assumption
##' that the prior medians are linear in log-dose on the logit scale, and
##' \code{\link{Quantiles2LogisticNormal}} is used to transform the resulting
##' quantiles into an approximating \code{\linkS4class{LogisticNormal}} (or
##' \code{\linkS4class{LogisticLogNormal}}) model. Note that the reference dose
##' is not required for these computations.
##'
##' @param dosegrid the dose grid
##' @param refDose the reference dose
##' @param threshmin Any toxicity probability above this threshold would
##' be very unlikely (see \code{probmin}) at the minimum dose (default: 0.2)
##' @param threshmax Any toxicity probability below this threshold would
##' be very unlikely (see \code{probmax}) at the maximum dose (default: 0.3)
##' @param probmin the prior probability of exceeding \code{threshmin} at the
##' minimum dose (default: 0.05)
##' @param probmax the prior probability of being below \code{threshmax} at the
##' maximum dose (default: 0.05)
##' @param \dots additional arguments for computations, see
##' \code{\link{Quantiles2LogisticNormal}}, e.g. \code{refDose} and
##' \code{logNormal=TRUE} to obtain a minimal informative log normal prior.
##' @return see \code{\link{Quantiles2LogisticNormal}}
##'
##' @example examples/MinimalInformative.R
##' @export
##' @keywords programming
MinimalInformative <- function(
  dosegrid,
  refDose,
  threshmin = 0.2,
  threshmax = 0.3,
  probmin = 0.05,
  probmax = 0.05,
  ...
) {
  ## extracts and checks
  nDoses <- length(dosegrid)

  assert_probability(threshmin, bounds_closed = FALSE)
  assert_probability(threshmax, bounds_closed = FALSE)
  assert_probability(probmin, bounds_closed = FALSE)
  assert_probability(probmax, bounds_closed = FALSE)
  stopifnot(
    !is.unsorted(dosegrid, strictly = TRUE)
  )
  xmin <- dosegrid[1]
  xmax <- dosegrid[nDoses]

  ## derive the beta distributions at the lowest and highest dose
  betaAtMin <- h_get_min_inf_beta(
    q = threshmin,
    p = 1 - probmin
  )
  betaAtMax <- h_get_min_inf_beta(
    q = threshmax,
    p = probmax
  )

  ## get the medians of those beta distributions
  medianMin <- with(
    betaAtMin,
    qbeta(p = 0.5, a, b)
  )
  medianMax <- with(
    betaAtMax,
    qbeta(p = 0.5, a, b)
  )

  ## now determine the medians of all beta distributions
  beta <- (logit(medianMax) - logit(medianMin)) / (log(xmax) - log(xmin))
  alpha <- logit(medianMax) - beta * log(xmax / refDose)
  medianDosegrid <- plogis(alpha + beta * log(dosegrid / refDose))

  ## finally for all doses calculate 95% credible interval bounds
  ## (lower and upper)
  lower <- upper <- dosegrid
  for (i in seq_along(dosegrid)) {
    ## get min inf beta distribution
    thisMinBeta <- h_get_min_inf_beta(
      p = 0.5,
      q = medianDosegrid[i]
    )

    ## derive required quantiles
    lower[i] <- with(
      thisMinBeta,
      qbeta(p = 0.025, a, b)
    )
    upper[i] <- with(
      thisMinBeta,
      qbeta(p = 0.975, a, b)
    )
  }

  ## now go to Quantiles2LogisticNormal
  Quantiles2LogisticNormal(
    dosegrid = dosegrid,
    refDose = refDose,
    lower = lower,
    median = medianDosegrid,
    upper = upper,
    level = 0.95,
    ...
  )
}

# nolint end

#' Helper Function to Set and Save the RNG Seed
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This code is basically copied from `stats:::simulate.lm`.
#'
#' @param seed an object specifying if and how the random number generator
#' should be initialized ("seeded"). Either `NULL` (default) or an
#' integer that will be used in a call to [set.seed()] before
#' simulating the response vectors. If set, the value is saved as the
#' `seed` slot of the returned object. The default, `NULL` will
#' not change the random generator state.
#' @return The integer vector containing the random number generate state will
#' be returned, in order to call this function with this input to reproduce
#' the obtained simulation results.
#'
#' @export
set_seed <- function(seed = NULL) {
  assert_number(seed, null.ok = TRUE)

  if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
    runif(1)
  }

  if (is.null(seed)) {
    get(".Random.seed", envir = .GlobalEnv)
  } else {
    seed <- as.integer(seed)
    r_seed <- get(".Random.seed", envir = .GlobalEnv)
    # Make sure r_seed exists in parent frame.
    assign(".r_seed", r_seed, envir = parent.frame())
    set.seed(seed)
    # Here we need the r_seed in the parent.frame!
    do.call(
      "on.exit",
      list(quote(assign(".Random.seed", .r_seed, envir = .GlobalEnv))),
      envir = parent.frame()
    )
    structure(seed, kind = as.list(RNGkind()))
  }
}

#' Helper Function to Obtain Simulation Results List
#'
#' The function `fun` can use variables that are visible to itself.
#' The names of these variables have to be given in the vector `vars`.
#'
#' @param fun (`function`)\cr the simulation function for a single iteration, which takes as
#' single parameter the iteration index.
#' @param nsim number of simulations to be conducted.
#' @param vars names of the variables.
#' @param parallel should the simulation runs be parallelized across the
#' clusters of the computer?
#' @param n_cores how many cores should be used for parallel computing?
#' @return The list with all simulation results (one iteration corresponds
#' to one list element).
#'
#' @importFrom parallel makeCluster
#' @importFrom parallelly availableCores
#' @keywords internal programming
get_result_list <- function(
  fun,
  nsim,
  vars,
  parallel,
  n_cores
) {
  assert_flag(parallel)
  assert_integerish(n_cores, lower = 1)

  if (!parallel) {
    lapply(
      X = seq_len(nsim),
      FUN = fun
    )
  } else {
    # Process all simulations.
    cores <- min(
      as.integer(n_cores),
      parallelly::availableCores()
    )

    # Start the cluster.
    cl <- parallel::makeCluster(cores)

    # Load the required R package.
    parallel::clusterEvalQ(cl, {
      library(crmPack)
      NULL
    })

    # Export local variables from the caller environment.
    # Note: parent.frame() is different from parent.env() which returns
    # the environment where this function has been defined!
    parallel::clusterExport(
      cl = cl,
      varlist = vars,
      envir = parent.frame()
    )

    # Export all global variables.
    parallel::clusterExport(
      cl = cl,
      varlist = ls(.GlobalEnv)
    )

    # Load user extensions from global options.
    crmpack_extensions <- getOption("crmpack_extensions")
    if (is.null(crmpack_extensions) != TRUE) {
      tryCatch(
        {
          parallel::clusterCall(cl, crmpack_extensions)
        },
        error = function(e) {
          stop("Failed to export crmpack_extensions: ", e$message)
        }
      )
    }

    # Do the computations in parallel.
    res <- parallel::parLapply(
      cl = cl,
      X = seq_len(nsim),
      fun = fun
    )

    # Stop the cluster.
    parallel::stopCluster(cl)

    res
  }
}


#' Helper Function to call truth calculation
#'
#' @param dose (`number`)\cr current dose.
#' @param truth (`function`)\cr defines the true probability for a DLT at a dose.
#' @param this_args (`data.frame`)\cr list of arguments for the truth.
#' @return The updated `this_truth`.
#'
#' @keywords internal
h_this_truth <- function(dose, this_args, truth) {
  do.call(
    truth,
    ## First argument: the dose
    c(
      dose,
      ## Following arguments
      this_args
    )
  )
}


#' Helper Function to create return list for Simulations output
#'
#' @param resultList (`list`)\cr raw iteration output.
#'
#' @return aggregated output for simulation object `list`.
#'
#' @keywords internal
h_simulations_output_format <- function(resultList) {
  ## put everything in the Simulations format:

  ## setup the list for the simulated data objects
  dataList <- lapply(resultList, "[[", "data")

  ## the vector of the final dose recommendations
  recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))

  ## setup the list for the final fits
  fitList <- lapply(resultList, "[[", "fit")

  ## the reasons for stopping
  stopReasons <- lapply(resultList, "[[", "stop")

  # individual stopping rule results as matrix, labels as column names
  stopResults <- lapply(resultList, "[[", "report_results")
  stop_matrix <- as.matrix(do.call(rbind, stopResults))

  # Result list of additional statistical summary.
  additional_stats <- lapply(resultList, "[[", "additional_stats")

  return(list(
    dataList = dataList,
    recommendedDoses = recommendedDoses,
    fitList = fitList,
    stopReasons = stopReasons,
    stopResults = stopResults,
    additional_stats = additional_stats,
    stop_matrix = stop_matrix
  ))
}


#' Helper function to recursively unpack stopping rules and return lists with
#' logical value and label given
#'
#' @param stopit_tree object from simulate method
#' @return named list

h_unpack_stopit <- function(stopit_tree) {
  label <- attr(stopit_tree, "report_label")
  value <- stopit_tree[1]
  names(value) <- label
  value
  if (is.null(attr(stopit_tree, "individual"))) {
    return(value)
  } else {
    return(unlist(c(
      value,
      lapply(attr(stopit_tree, "individual"), h_unpack_stopit)
    )))
  }
}


#' Helper function to determine the dlts including first separate and placebo
#' condition
#'
#' @param data (`Data`)\cr what data to start from.
#' @param dose (`number`)\cr current dose.
#' @param prob (`function`)\cr defines the true probability for a DLT at a dose.
#' @param prob_placebo (`function`)\cr defines the true probability for a DLT at a placebo condition.
#' @param cohort_size (`number`)\cr the cohort size to use.
#' @param cohort_size_placebo (`number`)\cr the cohort size to use for placebo condition.
#' @param dose_grid (`numeric`)\cr the dose_grid as specified by the user.
#' @param first_separate (`flag`)\cr whether the first patient is enrolled separately.
#' @return updated data object
#' @keywords internal

h_determine_dlts <- function(
  data,
  dose,
  prob,
  prob_placebo,
  cohort_size,
  cohort_size_placebo,
  dose_grid,
  first_separate
) {
  assert_class(data, "Data")
  assert_number(dose)
  assert_number(prob)
  assert_number(cohort_size)
  assert_flag(first_separate)

  if (first_separate && cohort_size > 1) {
    dlts <- rbinom(n = 1, size = 1, prob = prob)
    if ((data@placebo) && cohort_size_placebo > 0) {
      dlts_placebo <- rbinom(n = 1, size = 1, prob = prob_placebo)
    }
    if (dlts == 0) {
      dlts <- c(dlts, rbinom(n = cohort_size - 1L, size = 1, prob = prob))
      if ((data@placebo) && cohort_size_placebo > 0) {
        dlts_placebo <- c(
          dlts_placebo,
          rbinom(
            n = cohort_size_placebo, # cohort_size_placebo - 1?
            size = 1,
            prob = prob_placebo
          )
        )
      }
    }
  } else {
    dlts <- rbinom(n = cohort_size, size = 1, prob = prob)
    if ((data@placebo) && cohort_size_placebo > 0) {
      dlts_placebo <- rbinom(
        n = cohort_size_placebo,
        size = 1,
        prob = prob_placebo
      )
    }
  }

  if ((data@placebo) && cohort_size_placebo > 0) {
    this_data <- update(
      object = data,
      x = dose_grid,
      y = dlts_placebo,
      check = FALSE
    )

    ## update the data with active dose
    this_data <- update(
      object = this_data,
      x = dose,
      y = dlts,
      new_cohort = FALSE
    )
  } else {
    ## update the data with this cohort
    this_data <- update(
      object = data,
      x = dose,
      y = dlts
    )
  }
  return(this_data)
}

# v_mcmc_options ----

#' Internal Helper Functions for Validation of [`McmcOptions`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`McmcOptions`] or inherited classes and therefore not exported.
#'
#' @name v_mcmcoptions_objects
#' @param object (`McmcOptions`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_mcmcoptions_objects validates that the [`McmcOptions`]
#'   object contains valid integer scalars `iterations`, `burnin` and `step`
#'   as well as proper parameters for Random Number Generator.
v_mcmc_options <- function(object) {
  v <- Validate()
  allowed_rng_kinds <- c(
    "base::Wichmann-Hill",
    "base::Marsaglia-Multicarry",
    "base::Super-Duper",
    "base::Mersenne-Twister",
    NA_character_
  )

  v$check(
    test_int(object@iterations, lower = 1L),
    "iterations must be integer scalar greater than or equal to 1"
  )
  v$check(
    test_int(object@burnin, lower = 0L),
    "burn-in must be non-negative integer scalar"
  )
  # This below check should not be conducted in above test, using
  # `upper = object@iterations -1` argument, since object@iterations might be
  # not-valid. In such a case `test_int` throws an internal error.
  v$check(
    test_true(object@burnin < object@iterations),
    "burn-in must be lower than iterations"
  )
  v$check(
    test_int(object@step, lower = 1L),
    "step must be integer scalar greater than or equal to 1"
  )

  is_rng_kind_scalar <- test_string(object@rng_kind, na.ok = TRUE)
  v$check(is_rng_kind_scalar, "rng_kind must be a single string")
  v$check(
    test_subset(object@rng_kind, allowed_rng_kinds),
    paste0(
      "rng_kind must one of the following: ",
      paste(allowed_rng_kinds, collapse = ", "),
      ". User specifies the rng_kind without `base::` prefix"
    )
  )

  is_rng_seed_scalar <- test_int(object@rng_seed, na.ok = TRUE)
  v$check(is_rng_seed_scalar, "rng_seed must be an integer scalar")

  # Below `if` condition is not only reasonable but also needed as R CMD check
  # is activating some stricter checks and it fails when arguments to `||` are
  # not scalars, even if `||` works well with vectors of length > 1.
  if (is_rng_kind_scalar && is_rng_seed_scalar) {
    v$check(
      !is.na(object@rng_kind) || is.na(object@rng_seed),
      "rng_seed supplied but rng_kind not set"
    )
  }
  v$result()
}

# These functions will need to be amended to support the report_label slot if
# and when it is added to NextBest classes

# NextBestMTD ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param target_label (`character`)\cr the term used to describe the target
#' toxicity rate
#' @rdname knit_print
#' @export
#' @method knit_print NextBestMTD
knit_print.NextBestMTD <- function(
  x,
  ...,
  target_label = "the 25th centile",
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(target_label, len = 1, any.missing = FALSE)

  tox_label <- h_prepare_labels(tox_label)
  # Execute
  rv <- paste0(
    "The dose level recommended for the next cohort will be selected as follows:\n\n",
    "-  First, ",
    target_label,
    " of the posterior distribution of ",
    tox_label[1],
    " will be calculated for all dose levels that are eligible according to the ",
    " Increments rule.\n",
    "-  Next, the \"target dose\" (which may not be part of the dose grid) for which ",
    target_label,
    " of the posterior distribution of ",
    tox_label[1],
    " is exactly equal to the target rate of ",
    x@target,
    " will be determined.\n",
    "- Finally, the dose level whose absolute distance from the target dose ",
    "is smallest will be selected as the recommended dose for the next cohort\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestNCRM ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestNCRM
knit_print.NextBestNCRM <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, max.len = 2, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be chosen in the following ",
    "way.  First, doses that are ineligible according to the increments rule ",
    "will be discarded.  Next, any dose for which the mean posterior probability of ",
    tox_label,
    " being in the overdose range - (",
    x@overdose[1],
    ", ",
    x@overdose[2],
    "] - is ",
    x@max_overdose_prob,
    " or more will also be discarded.  Finally, the dose amongst those remaining ",
    "which has the highest chance that the mean posterior probability of ",
    tox_label,
    " is in the target ",
    tox_label,
    " range of ",
    x@target[1],
    " to ",
    x@target[2],
    " (inclusive) will be selected.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestThreePlusThree ----

#' @description `r lifecycle::badge("experimental")`
#' @param label (`character`)\cr The term used to label the participants.
#' @param tox_label (`character`)\cr the term used to describe toxicity.  See
#' Usage Notes below.
#' See Usage Notes below.
#' @section Usage Notes:
#' This section describes the use of `label` and `tox_label`, collectively
#' referred to as `label`s.
#' A `label` should be a scalar or a vector of length 2.  If a scalar, it is
#' converted by adding a second element that is equal to the first, suffixed by `s`.
#' For example, `tox_label = "DLT"` becomes `tox_label = c("DLT", "DLTs")`.  The
#' first element of the vector is used to describe a count of 1.  The second
#' is used in all other cases.
#' @rdname knit_print
#' @export
#' @method knit_print NextBestThreePlusThree
knit_print.NextBestThreePlusThree <- function(
  x,
  ...,
  tox_label = c("toxicity", "toxicities"),
  label = "participant",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)

  # Prepare
  tox_label <- h_prepare_labels(tox_label)
  label <- h_prepare_labels(label)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be chosen using the \"Three ",
    "Plus Three\" rule.\n\n- If no ",
    tox_label[2],
    " have been reported at the current dose level, escalate by one dose level.\n",
    "- If the observed ",
    tox_label[1],
    " rate at the current dose level is exactly 1/3 and no more than three ",
    label[2],
    " treated at the current dose level are evaluable, remain at the current ",
    "dose level.\n",
    "- Otherwise, recommend that the trial stops and identify the MTD as dose ",
    "level immediately below the current one.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestDualEndpoint ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param biomarker_label (`character`)\cr the term used to describe the biomarker
#' @param biomarker_units (`character`)\cr the units in which the biomarker is
#' measured
#' @rdname knit_print
#' @export
#' @method knit_print NextBestDualEndpoint
knit_print.NextBestDualEndpoint <- function(
  x,
  ...,
  tox_label = "toxicity",
  biomarker_label = "the biomarker",
  biomarker_units = ifelse(x@target_relative, "%", ""),
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(biomarker_label, len = 1, any.missing = FALSE)
  assert_character(biomarker_units, len = 1, any.missing = FALSE)

  rv <- paste0(
    "The dose recommended for the next cohort will be chosen in the following ",
    "way.  First, doses that are ineligible according to the increments rule ",
    "will be discarded.  Next, any dose for which the mean posterior probability of ",
    tox_label,
    " being in the overdose range - (",
    x@overdose[1],
    ", ",
    x@overdose[2],
    "] - is ",
    x@max_overdose_prob,
    " or more will also be discarded.  Finally, the dose amongst those remaining ",
    "which has the highest chance that the mean posterior probability that ",
    biomarker_label,
    " is in the target range for ",
    biomarker_label,
    ", which is ",
    x@target[1],
    ifelse(
      x@target_relative,
      "",
      stringr::str_squish(paste0(" ", biomarker_units))
    ),
    " to ",
    x@target[2],
    ifelse(
      x@target_relative,
      "",
      stringr::str_squish(paste0(" ", biomarker_units))
    ),
    " (inclusive),",
    ifelse(
      x@target_relative,
      paste0(" of the maximum ", biomarker_label, " value"),
      ""
    ),
    " will be selected, provided that this probability exceeds ",
    x@target_thresh,
    ".  If no dose meets this threshold, then the highest eligible dose will ",
    "be selected.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestMinDist ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestMinDist
knit_print.NextBestMinDist <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is both ",
    "eligible and which has the smallest absolute difference between ",
    "its mean posterior estimate of the probability of ",
    tox_label,
    " and the target ",
    tox_label,
    " rate [",
    x@target,
    "].\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestInfTheory ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param citation_text (`character`)\cr the text used to cite Mozgunov & Jaki
#' @param citation_link (`character`)\cr the link to Mozgunov & Jaki
#' @section Usage Notes:
#' To use a BibTeX-style citation, specify (for example) `citation_text =
#' "@MOZGUNOV", citation_link = ""`.
#' @rdname knit_print
#' @export
#' @method knit_print NextBestInfTheory
knit_print.NextBestInfTheory <- function(
  x,
  ...,
  tox_label = "toxicity",
  citation_text = "Mozgunov & Jaki (2019)",
  citation_link = "https://doi.org/10.1002/sim.8450",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(citation_text, len = 1, any.missing = FALSE)
  assert_character(citation_link, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The recommended dose for the next cohort will be chosen using the ",
    "complex infinite bounds penalisation (CIBP) criterion of ",
    "[",
    citation_text,
    "]",
    ifelse(nchar(citation_link) > 0, paste0("(", citation_link, ")"), ""),
    ".  Let\n\n",
    "$$ \\delta(\\hat{p}_d, \\gamma) = \\frac{(\\hat{p}_d - \\gamma)^2}",
    "{\\hat{p}_d^a \\cdot (1 - \\hat{p}_d)^{2 - a}} $$\n\n",
    "where a is the non-centrality parameter with a value of ",
    x@asymmetry,
    ", &gamma; is the target ",
    tox_label,
    " rate with a value of ",
    x@target,
    " and $\\hat{p}_d$ is the mean posterior estimate of the probability of ",
    tox_label,
    " at dose level d.\n\n",
    "The recommended dose for the next cohort will be ",
    "the value of d that minimises $\\delta(\\hat{p}_d, \\gamma)$.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestTD ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestTD
knit_print.NextBestTD <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is both ",
    "eligible and which is the highest dose in the dose grid strictly less than ",
    "the dose (which may not be in the dose grid) that has a posterior plug-in ",
    "estimate of the probability of ",
    tox_label,
    " exactly equal to the target ",
    tox_label,
    " rate, either during [",
    x@prob_target_drt,
    "] or at the end of the trial [",
    x@prob_target_eot,
    "].\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestMaxGain ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestMaxGain
knit_print.NextBestMaxGain <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is closest to ",
    "Gstar, the dose that maximises the gain for probability of ",
    tox_label,
    " exactly equal to the target ",
    tox_label,
    " rate, either during [",
    x@prob_target_drt,
    "] or at the end of the trial [",
    x@prob_target_eot,
    "].\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestProbMTDLTE ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestProbMTDLTE
knit_print.NextBestProbMTDLTE <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the dose level with ",
    "the highest probability of being the highest dose with an estimated ",
    "probability of ",
    tox_label,
    " less than or equal to ",
    x@target,
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestProbMTDMinDist ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestProbMTDMinDist
knit_print.NextBestProbMTDMinDist <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the dose level with ",
    "the highest probability of being the highest dose with an estimated ",
    "probability of ",
    tox_label,
    " closest to ",
    x@target,
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestNCRMLoss ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param format_func (`function`)\cr The function used to format the range table.
#' @importFrom rlang .data
#' @rdname knit_print
#' @export
#' @method knit_print NextBestNCRMLoss
knit_print.NextBestNCRMLoss <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE,
  format_func = h_knit_format_func
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  param <- list(...)
  param[["x"]] <- x %>%
    tidy() %>%
    dplyr::select(-MaxOverdoseProb)
  param[["col.names"]] <- c("Range", "Lower", "Upper", "Loss Coefficient")
  rv <- paste0(
    "The dose recommended for the next cohort will be chosen in the following ",
    "way:\n\n-  First, the chance that the probability of ",
    tox_label,
    " falls into each of the underdose, target ",
    ifelse(
      any(x@unacceptable != c(1, 1)),
      ", overdose and unacceptable",
      " and overdose"
    ),
    " dose ranges is calculated for element of the dose grid.\n",
    "-  Next, the loss associated with each dose is calculated by multiplying ",
    "these probabilities by the corresponding loss coefficient and summing the result.\n",
    "-  Then ineligible doses, and those with a probability of being in the ",
    ifelse(
      length(x@losses) == 3,
      "overdose range",
      "overdose or unaccaptable ranges"
    ),
    " that is greater than ",
    x@max_overdose_prob,
    ", are discarded.\n",
    "-  Finally, the dose level with the smallest loss is selected as the ",
    "recommended dose for the next cohort.\n\n",
    ifelse(
      toupper(tox_label) == tox_label,
      tox_label,
      stringr::str_to_sentence(tox_label)
    ),
    " ranges and loss coefficients are given in the following table:\n\n",
    paste((do.call(knitr::kable, param)) %>% format_func(), collapse = "\n"),
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestTDsamples ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestTDsamples
knit_print.NextBestTDsamples <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is both ",
    "eligible and which is the highest dose in the dose grid strictly less than ",
    "the dose (which may not be in the dose grid) that has a full Bayes posterior ",
    "estimate of the probability of ",
    tox_label,
    " exactly equal to the target ",
    tox_label,
    " rate, either during [",
    x@prob_target_drt,
    "] or at the end of the trial [",
    x@prob_target_eot,
    "].\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}


# NextBestMaxGainSamples ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestMaxGainSamples
knit_print.NextBestMaxGainSamples <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is closest to ",
    "Gstar, the dose for which the full Bayes posterior estimate of the probability of ",
    tox_label,
    " maximises the gain relative to the target ",
    tox_label,
    " rate, either during [",
    x@prob_target_drt,
    "] or at the end of the trial [",
    x@prob_target_eot,
    "].\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestOrdinal
knit_print.NextBestOrdinal <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  assert_flag(asis)
  assert_character(tox_label, max.len = 2, any.missing = FALSE)

  tox_label <- h_prepare_labels(tox_label)
  rv <- paste0(
    "Based on a ",
    tox_label[1],
    " grade of ",
    x@grade,
    ": ",
    paste0(
      knit_print(x@rule, asis = asis, tox_label = tox_label, ...),
      collapse = "\n"
    ),
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Format a `doseGrid` for Printing
#'
#' @param grid (`numeric`)\cr the dose grid
#' @param units (`character`)\cr The units in which the values in `doseGrid` are
#' @param fmt (`character`)\cr The format used to display values in `doseGrid`.
#' If `NA`, grid values are not pre-formatted
#' @param ... not used at present
#' measured.  Appended to each value in `doseGrid` when `knit_print`ed.  The
#' default, `NA`, omits the units.
#' @return A character string containing the formatted dose grid.  If the grid
#' is `c(1, 2, 3)` and `units` is `"mg"`, the returned value is `"1 mg, 2 mg and 3 mg"`.
#' @keywords internal
h_get_formatted_dosegrid <- function(grid, units = NA, fmt = NA, ...) {
  assert_numeric(
    grid,
    lower = 0,
    min.len = 2,
    unique = TRUE,
    finite = TRUE,
    sorted = TRUE,
    any.missing = FALSE
  )
  assert_character(units, len = 1)

  n <- length(grid)
  units <- h_prepare_units(units)
  formattedGrid <- if (is.na(fmt)) {
    as.character(grid)
  } else {
    sprintf(fmt, grid)
  }
  paste0(
    paste(
      lapply(
        formattedGrid[1:(n - 1)],
        paste0,
        sep = units
      ),
      collapse = ", "
    ),
    " and ",
    formattedGrid[n],
    paste0(units, ".\n\n")
  )
}

#' Set Column Headers in Custom `knit_print` Methods
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`ANY`)\cr object that will be printed
#' @param param (`list`)\cr A list of the `...` parameters passed to `knit_print`
#' @param summarise (`flag`)\cr Is the object to be summarised (default) or listed?
#' @return A character vector of column names.
#' @noRd
h_knit_print_set_headers <- function(x, param, summarise, ...) {
  UseMethod("h_knit_print_set_headers")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.GeneralData <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c("ID", "Cohort", "Dose", "DLT?")
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.DataDA <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c(
        "ID",
        "Cohort",
        "Dose",
        "Tox",
        "U",
        "T0",
        "TMax"
      )
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.DataGrouped <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c("ID", "Cohort", "Dose", "Group", "Tox")
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Group", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c(
        "Cohort",
        "Group",
        "Evaluable",
        "With Toxicities"
      )
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.DataParts <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c("ID", "Part", "Cohort", "Dose", "Tox")
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_set_headers.DataOrdinal <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c(
        "ID",
        "Cohort",
        "Dose",
        paste0("Cat", 0:(length(x@yCategories) - 1))
      )
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", names(x@yCategories))
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", names(x@yCategories))
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.DataDual <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c("ID", "Cohort", "Dose", "Tox", "W")
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
    }
  }
  param
}

#' Select Columns to Print in Custom `knit_print` Methods
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`ANY`)\cr object that will be printed
#' @param ... Not used at present.
#' @return A tidied version of `x`, containing only the selected columns.
#' @noRd
h_knit_print_select_columns <- function(x, ...) {
  UseMethod("h_knit_print_select_columns")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.GeneralData <- function(x, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Tox")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.Data <- function(x, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Tox")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataParts <- function(x, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Part", "Cohort", "Dose", "Tox")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataOrdinal <- function(x, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", tidyselect::starts_with("Cat"))
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataDA <- function(x, param, summarise, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Tox", "U", "T0", "TMax")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataGrouped <- function(x, param, summarise, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Group", "Tox")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataDual <- function(x, param, summarise, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Tox", "W")
}

#' Summarise a `Data` Object by Dose or Cohort for Display in Custom `knit_print` Methods
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`ANY`)\cr object that will be printed
#' @param full_grid (`flag`)\cr Should the full grid be included or only those
#' doses with at least one evaluable participant?
#' @param ... Not used at present.
#' @return A tibble containing the summarised data
#' @noRd
h_knit_print_summarise <- function(x, summarise, full_grid, ...) {
  UseMethod("h_knit_print_summarise")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_summarise
#' @noRd
h_knit_print_summarise.GeneralData <- function(x, summarise, full_grid, ...) {
  xTidy <- x %>% tidy()
  xTidy <- xTidy %>%
    dplyr::group_by(.data[[stringr::str_to_title(summarise)]]) %>%
    dplyr::summarise(
      N = dplyr::n(),
      ToxCount = sum(Tox)
    )
  if (full_grid && summarise == "dose") {
    xTidy <- xTidy %>%
      tidyr::complete(
        Dose = x@doseGrid,
        fill = list(ToxCount = 0, N = 0)
      )
  }
  xTidy
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_summarise
#' @noRd
h_knit_print_summarise.DataOrdinal <- function(x, summarise, full_grid, ...) {
  xTidy <- x %>% tidy()
  xTidy <- xTidy %>%
    dplyr::group_by(.data$Dose) %>%
    dplyr::summarise(
      N = dplyr::n(),
      dplyr::across(tidyselect::starts_with("Cat"), sum)
    )
  if (full_grid && summarise == "dose") {
    replace_list <- as.list(
      c(
        "N",
        names(xTidy)[which(stringr::str_detect(names(xTidy), "Cat\\d+"))]
      )
    )
    # Create a list whose names are the columns in which we need to replace NAs
    # and whose values are 0
    names(replace_list) <- sapply(replace_list, \(x) x)
    replace_list <- lapply(replace_list, \(x) 0)
    # Expand the tibble and do the replacement
    xTidy <- tidyr::expand_grid(Dose = x@doseGrid) %>%
      dplyr::left_join(xTidy, by = "Dose") %>%
      tidyr::replace_na(replace_list)
  }
  xTidy
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_summarise
#' @noRd
h_knit_print_summarise.DataGrouped <- function(x, summarise, full_grid, ...) {
  xTidy <- x %>% tidy()
  xTidy <- xTidy %>%
    dplyr::group_by(.data[[stringr::str_to_title(summarise)]], .data$Group) %>%
    dplyr::summarise(
      N = dplyr::n(),
      ToxCount = sum(Tox)
    )
  if (full_grid && summarise == "dose") {
    xTidy <- tidyr::expand_grid(
      Dose = x@doseGrid,
      Group = c("mono", "combo")
    ) %>%
      dplyr::left_join(xTidy, by = c("Dose", "Group")) %>%
      tidyr::replace_na(list(N = 0, ToxCount = 0))
  }
  xTidy
}

#' Print a `GeneralData` Object in a Markdown or Quarto Chunk
#'
#' @param label (`character`)\cr How to describe the participants in the trial.
#' See Usage Notes below.
#' @param full_grid (`flag`)\cr Should the full dose grid appear in the output table
#' or simply those doses for whom at least one evaluable participant is available?
#' Ignored unless `summarise == "dose"`.
#' @param summarise (`character`)\cr How to summarise the observed data.  The default,
#' `"none"`, lists observed data at the participant level.  `"dose"` presents
#' participant counts by dose and `"cohort"` by cohort.
#' @param summarize (`character`)\cr Synonym for `summarise`
#' @param format_func (`function`)\cr The function used to format the participant table.
#' The default applies no formatting.  Obvious alternatives include `kableExtra::kable_styling`.
#' @param ... passed to [knitr::kable()]
#' @section Usage Notes:
#' `label` describes the trial's participants.
#'
#' It should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a single participant and the second describes all other
#' situations.  If of length 1, the character `s` is appended to the value
#' when the number of participants is not 1.
#' The default values of `col.names` and `caption` vary depending on the summary
#' requested. The default values can be overridden by passing `col.names` and
#' `caption` in the function call.
#'
#' @inheritParams h_get_formatted_dosegrid
#' @export
#' @method knit_print GeneralData
#' @rdname knit_print
knit_print.GeneralData <- function(
  x,
  ...,
  asis = TRUE,
  label = c("participant", "participants"),
  full_grid = FALSE,
  summarise = c("none", "dose", "cohort"),
  summarize = summarise,
  units = NA,
  format_func = h_knit_format_func
) {
  # Validate
  assert_flag(asis)
  assert_flag(full_grid)
  assert_function(format_func)
  summarise <- match.arg(summarise)
  summarize <- match.arg(summarize)

  if (is.na(summarise) || is.null(summarise)) {
    summarise <- summarize
  }
  assert_choice(summarise, c("none", "dose", "cohort"))
  # Initialise
  label <- h_prepare_labels(label)
  param <- list(...)

  # Execute
  param <- h_knit_print_set_headers(x, param, summarise, ...)
  if (summarise == "none") {
    if (!("caption" %in% names(param))) {
      param[["caption"]] <- paste("Evaluable", label[2], "to-date")
    }
    xTidy <- h_knit_print_select_columns(x)
  } else {
    xTidy <- h_knit_print_summarise(x, summarise, full_grid)
    if (!("caption" %in% names(param))) {
      param[["caption"]] <- paste0("Summarised by ", summarise)
    }
  }
  param[["x"]] <- xTidy
  rv <- if (length(x@x) > 0) {
    paste((do.call(knitr::kable, param)) %>% format_func(), collapse = "\n")
  } else {
    paste("No", label[2], "are yet evaluable.\n\n")
  }
  rv <- paste0(
    rv,
    paste0(
      "\n\nThe dose grid is ",
      h_get_formatted_dosegrid(
        grid = x@doseGrid,
        units = units,
        ...
      ),
      ""
    ),
    "\n\n",
    collpase = "\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Used to obtain expected format.
#' @keywords internal
h_knit_format_func <- function(x) {
  kableExtra::kable_styling(
    x,
    bootstrap_options = c("striped", "hover", "condensed")
  )
}

#' @export
#' @method knit_print DataParts
#' @rdname knit_print
knit_print.DataParts <- function(
  x,
  ...,
  asis = TRUE,
  label = c("participant", "participants"),
  full_grid = FALSE,
  summarise = c("none", "dose", "cohort"),
  summarize = summarise,
  units = NA,
  format_func = h_knit_format_func
) {
  rv <- NextMethod()
  rv <- paste0(
    rv,
    paste0(
      "\n\nThe part 1 ladder is ",
      h_get_formatted_dosegrid(x@part1Ladder, units)
    ),
    paste0("\n\nThe next part is Part ", x@nextPart, ".\n\n")
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @include McmcOptions-class.R
NULL

# size ----

## generic ----

#' Size of an Object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that computes the size of a given object. This can be for instance
#' a size of a MCMC sample, or the size of a cohort. See the help of a specific
#' method for more details.
#'
#' @param object (`McmcOptions` or `Samples` or `CohortSize`)\cr an object
#'   for which the size is computed.
#' @param ... further arguments passed to `size` specific methods.
#'
#' @return A size of a given object.
#' @export
#'
setGeneric(
  name = "size",
  def = function(object, ...) {
    standardGeneric("size")
  },
  valueClass = "integer"
)

## McmcOptions ----

#' @describeIn size compute the number of MCMC samples based on `McmcOptions`
#'   object.
#' @aliases size-McmcOptions
#' @example examples/McmcOptions-methods-size.R
setMethod(
  f = "size",
  signature = signature(object = "McmcOptions"),
  definition = function(object, ...) {
    iterations_relative <- object@iterations - object@burnin
    if (iterations_relative <= 0) {
      return(0L)
    }
    as.integer(floor(iterations_relative / object@step))
  }
)

# saveSample ----

## generic ----

#' Determining if this Sample Should be Saved
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that determines if a sample from a given `iteration` should be
#' saved. The sample should be saved if and only if:
#' it is not in burn-in period and it matches the `step`.
#'
#' @param object (`McmcOptions`)\cr object based on which the answer is
#'   determined.
#' @param iteration (`count`)\cr the current iteration index.
#' @param ... not used.
#' @return `TRUE` if this sample should be saved.
#' @export
#'
setGeneric(
  name = "saveSample",
  def = function(object, iteration, ...) {
    standardGeneric("saveSample")
  },
  valueClass = "logical"
)

## McmcOptions ----

#' @describeIn saveSample determine if a sample should be saved.
#' @aliases saveSample-McmcOptions
#' @example examples/McmcOptions-methods-saveSample.R
setMethod(
  f = "saveSample",
  signature = signature(object = "McmcOptions"),
  definition = function(object, iteration, ...) {
    iteration_relative <- iteration - object@burnin
    iteration_relative > 0 && ((iteration_relative %% object@step) == 0)
  }
)

# assertions ----

#' Additional Assertions for `checkmate`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' We provide additional assertion functions that can be used together with
#' the `checkmate` functions. These are described in individual help pages
#' linked below.
#'
#' @return Depending on the function prefix.
#' - `assert_` functions return the object invisibly if successful, and otherwise
#'   throw an error message.
#' - `check_` functions return `TRUE` if successful, otherwise a string with the
#'   error message.
#' - `test_` functions just return `TRUE` or `FALSE`.
#'
#' @seealso [assert_probabilities()], [assert_probability()],
#'   [assert_probability_range()], [assert_length()].
#'
#' @name assertions
NULL

# check equality ----

#' Check if All Arguments Are Equal
#'
#' @description `r lifecycle::badge("experimental")`
#' Elements of `...` must be numeric vectors or scalars.
#'
#' This function performs an element-by-element comparison of the first object
#' provided in `...` with every other object in `...` and returns `TRUE` if all
#' comparisons are equal within a given tolerance and `FALSE` otherwise.
#'
#' @param ... (`numeric`)\cr vectors to be compared.
#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
#' judging equality.
#'
#' @note If there are any missing or infinite values in `...`, this function
#'   returns `FALSE`, regardless of the values of other elements in `...`.
#'
#' @note If elements in `...` are not all of the same length, `FALSE` is returned.
#'
#' @return `TRUE` if all element-by-element differences are less than `tolerance`
#' in magnitude, `FALSE` otherwise.
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_equal(1:2, 1:2) # TRUE
#' check_equal(1:2, 2:3) # "Not all equal"
#' check_equal(Inf, Inf) # "Not all equal"
#' check_equal(0.01, 0.02) # "Not all equal"
#' check_equal(0.01, 0.02, tol = 0.05) # TRUE
#' check_equal(1, c(1, 1)) # "Not all equal"
check_equal <- function(..., tol = sqrt(.Machine$double.eps)) {
  dot_args <- list(...)

  sapply(dot_args, assert_numeric)

  tmp <- sapply(dot_args, length)
  if (min(tmp) != max(tmp)) {
    return("Not all of same length")
  }
  if (any(sapply(dot_args, is.na))) {
    return("Some entries NA")
  }
  if (any(sapply(dot_args, is.infinite))) {
    return("Not all entries finite")
  }
  if (!all(sapply(dot_args, test_numeric))) {
    return("Not all numeric")
  }

  all_ok <- test_true(
    all(
      sapply(
        2:length(dot_args),
        function(z) abs(dot_args[[1]] - dot_args[[z]]) < tol
      )
    )
  )
  if (all_ok) {
    return(TRUE)
  }
  "Not all equal"
}

#' Assert That All Arguments Are Equal
#'
#' @description `r lifecycle::badge("experimental")`
#' Elements of `...` must be numeric vectors or scalars.
#'
#' This function performs an element-by-element comparison of the first object
#' provided in `...` with every other object in `...` and throws an error if they
#' are not.
#'
#' @param ... (`numeric`)\cr vectors to be compared
#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
#' judging equality
#'
#' @note If there are any missing or infinite values in `...`, this function
#'   throws an error, regardless of the values of other elements in `...`.
#'
#' @note If elements in `...` are not all of the same length, an error is thrown.
#'
#' @return `list(...)`, invisibly.
#' @seealso [`assertions`] for more details.
#' @inheritParams checkmate::assert_numeric
#'
#' @export
#' @rdname check_equal
#' @examples
#' assert_equal(1:2, 1:2) # no error
#' assert_equal(0.01, 0.02, tol = 0.05) # no error
# nolint start
assert_equal <- function(
  ...,
  tol = sqrt(.Machine$double.eps),
  .var.name = vname(x),
  add = NULL
) {
  # assert_equal <- makeAssertionFunction(check_equal) fails with error "Error
  # in `checkmate::makeAssertion(..., res, .var.name, add)`: unused argument
  # (add)", possibly because of the use of ... in check_equal.
  res <- check_equal(..., tol = tol)
  makeAssertion(list(...), res, .var.name, add)
}
# nolint end

# assert_probabilities ----

#' Check if an argument is a probability vector
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Check if every element in a given numerical vector or matrix represents a
#' probability, that is a number within (0, 1) interval, that can optionally be
#' closed at any side.
#'
#' @note If there are any missing or non-finite values in `x`, this function
#'   returns `FALSE`, regardless of the values of other elements in `x`.
#'
#' @param x (`numeric`)\cr vector or matrix with numerical values to check.
#' @param bounds_closed (`logical`)\cr should bounds be closed? This can be a
#'   scalar or vector of length two. If it is a scalar, then its value applies
#'   equally to lower bound \eqn{0} and upper bound \eqn{1}. If this is a vector
#'   with two flags, the first flag corresponds to the lower bound \eqn{0}
#'   only, and the second to the upper bound \eqn{1} only.
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' x <- c(0, 0.2, 0.1, 0.3, 1)
#' check_probabilities(x)
#' check_probabilities(x, bounds_closed = FALSE)
#' check_probabilities(x, bounds_closed = c(FALSE, TRUE))
check_probabilities <- function(
  x,
  bounds_closed = TRUE,
  len = NULL,
  unique = FALSE,
  sorted = FALSE
) {
  assert_numeric(x)
  assert_logical(bounds_closed, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_number(len, null.ok = TRUE)
  assert_flag(sorted)

  result <- check_numeric(
    x,
    finite = TRUE,
    any.missing = FALSE,
    len = len,
    unique = unique,
    sorted = sorted
  )

  if (isTRUE(result)) {
    in_bounds <- all(h_in_range(
      x,
      range = c(0L, 1L),
      bounds_closed = bounds_closed
    ))
    if (!in_bounds) {
      result <- paste(
        "Probability must be within",
        ifelse(bounds_closed[1], "[0,", "(0,"),
        ifelse(tail(bounds_closed, 1), "1]", "1)"),
        "bounds but it is not"
      )
    }
  }

  result
}

#' @rdname check_probabilities
#' @inheritParams check_probabilities
#' @export
assert_probabilities <- makeAssertionFunction(check_probabilities)

#' @rdname check_probabilities
#' @inheritParams check_probabilities
#' @export
test_probabilities <- makeTestFunction(check_probabilities)

#' @rdname check_probabilities
#' @inheritParams check_probabilities
#' @export
expect_probabilities <- makeExpectationFunction(check_probabilities)

# assert_probability ----

#' Check if an argument is a single probability value
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Check if a given value represents a probability, that is a number within
#' (0, 1) interval, that can optionally be closed at any side.
#'
#' @param x (`number`)\cr a single value to check.
#' @inheritParams check_probabilities
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_probability(0.5)
#' check_probability(0, bounds_closed = FALSE)
#' check_probability(0, bounds_closed = c(FALSE, TRUE))
check_probability <- function(x, bounds_closed = TRUE) {
  check_probabilities(x = x, bounds_closed = bounds_closed, len = 1)
}

#' @rdname check_probability
#' @inheritParams check_probability
#' @export
assert_probability <- makeAssertionFunction(check_probability)

#' @rdname check_probability
#' @inheritParams check_probability
#' @export
test_probability <- makeTestFunction(check_probability)

#' @rdname check_probability
#' @inheritParams check_probability
#' @export
expect_probability <- makeExpectationFunction(check_probability)

# assert_probability_range ----

#' Check if an argument is a probability range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Check if a given numerical interval represents a probability range, that is
#' a sub-interval of (0, 1) interval, that can optionally be closed at any side.
#'
#' @param x (`number`)\cr an interval to check.
#' @inheritParams check_probabilities
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' x <- c(0, 0.2)
#' check_probability_range(x)
#' check_probability_range(rev(x))
#' check_probability_range(x, bounds_closed = FALSE)
#' check_probability_range(x, bounds_closed = c(FALSE, TRUE))
check_probability_range <- function(x, bounds_closed = TRUE) {
  check_probabilities(
    x = x,
    bounds_closed = bounds_closed,
    len = 2,
    sorted = TRUE
  )
}

#' @rdname check_probability_range
#' @inheritParams check_probability_range
#' @export
assert_probability_range <- makeAssertionFunction(check_probability_range)

#' @rdname check_probability_range
#' @inheritParams check_probability_range
#' @export
test_probability_range <- makeTestFunction(check_probability_range)

#' @rdname check_probability_range
#' @inheritParams check_probability_range
#' @export
expect_probability_range <- makeExpectationFunction(check_probability_range)

# assert_length ----

#' Check if vectors are of compatible lengths
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Two vectors are of compatible size if and only if: \cr
#' 1. At least one vector has size 1 \cr
#' 2. or both vectors are of the same size. \cr
#'
#' @param x (`any`)\cr the first vector, any object for which [length()]
#'   function is defined.
#' @param len (`count`)\cr the length of the second vector.
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_length(1:5, 1)
#' check_length(1:5, 6)
#' check_length(1:5, 5)
#' check_length(10, 1)
#' check_length(10, 9)
check_length <- function(x, len) {
  x_len <- length(x)
  assert_true(x_len >= 1L)
  assert_count(len)

  if (x_len == 1L || len == 1L || x_len == len) {
    TRUE
  } else {
    paste(
      "x is of length",
      x_len,
      "which is not allowed; the allowed lengths are: 1 or",
      len,
      collapse = ""
    )
  }
}

#' @rdname check_length
#' @inheritParams check_length
#' @export
assert_length <- makeAssertionFunction(check_length)

#' @rdname check_length
#' @inheritParams check_length
#' @export
test_length <- makeTestFunction(check_length)

# assert_range ----

#' Check that an argument is a numerical range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' An argument `x` is a numerical range if and only if (all conditions must be met):
#' 1. Is an object of type: `integer` or `double`.
#' 2. Is a vector or length two such that the value of the first number is not
#' less than the second number. Equalness is allowed if and only if `unique` flag
#' is set to `TRUE`.
#' 3. Lower bound of the interval is greater than or equal to `lower` and
#' upper bound of the interval is less than or equal to `upper`.
#' 4. It contains only finite (given that `finite` is `TRUE`) and non-missing values.
#'
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_range(c(1, 5))
#' check_range(c(-5, 1))
#' check_range(c(4, 1))
#' check_range(c(1, 1))
#' check_range(c(1, 1), unique = FALSE)
#' check_range(1:3)
check_range <- function(
  x,
  lower = -Inf,
  upper = Inf,
  finite = FALSE,
  unique = TRUE
) {
  assert_number(lower)
  assert_number(upper)
  assert_flag(finite)
  assert_flag(unique)

  result <- check_numeric(
    x,
    lower = lower,
    upper = upper,
    finite = finite,
    any.missing = FALSE,
    len = 2,
    unique = unique,
    sorted = TRUE
  )

  if (!isTRUE(result)) {
    result <- paste("x must be a valid numerical range.", result)
  }
  result
}

#' @rdname check_range
#' @inheritParams check_range
#' @export
assert_range <- makeAssertionFunction(check_range)

#' @rdname check_range
#' @inheritParams check_range
#' @export
test_range <- makeTestFunction(check_range)

#' @rdname check_range
#' @inheritParams check_range
#' @export
expect_range <- makeExpectationFunction(check_range)

# assert_format ----

#' Check that an argument is a valid format specification
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_format("%5.2f")
check_format <- function(x, len = NULL, min.len = NULL, max.len = NULL) {
  assert_number(len, lower = 1, null.ok = TRUE)
  assert_number(min.len, lower = 1, null.ok = TRUE)
  assert_number(max.len, lower = 1, null.ok = TRUE)

  result <- check_character(
    x,
    len = len,
    min.len = min.len,
    max.len = max.len,
    any.missing = FALSE,
    # https://stackoverflow.com/questions/446285/validate-sprintf-format-from-input-field-with-regex
    pattern = "%(?:\\d+\\$)?[+-]?(?:[ 0]|'.{1})?-?\\d*(?:\\.\\d+)?[bcdeEufFgGosxX]",
  )

  if (!isTRUE(result)) {
    result <- paste("x must be a valid format specifier.", result)
  }
  result
}

#' @rdname check_format
#' @inheritParams check_format
#' @export
assert_format <- makeAssertionFunction(check_format)

#' @rdname check_format
#' @inheritParams check_format
#' @export
test_format <- makeTestFunction(check_format)

#' @rdname check_format
#' @inheritParams check_format
#' @export
expect_format <- makeExpectationFunction(check_format)

#' Helper Function to Blind Plot Data
#'
#' @param df (`GeneralData`)\cr The data to be blinded
#' @param blind (`flag`)\cr Should the data be blinded?
#' @param has_placebo (`flag`)\cr Does the data contain a placebo dose?
#' @param pbo_dose (`positive_number`)\cr The dose to be taken as placebo.
#' Ignored if `has_placebo` is `FALSE`
#' @returns The blinded data
h_blind_plot_data <- function(df, blind, has_placebo, pbo_dose) {
  if (blind) {
    # This is to blind the data.
    # For each cohort, all DLTs are assigned to the first subjects in the cohort.
    # In addition, the placebo (if any) is set to the active dose level for that
    # cohort.
    # Notice: dapply reorders records of df according to the lexicographic order
    # of cohort.
    df <- dapply(df, f = ~cohort, FUN = function(coh) {
      coh$toxicity <- sort(coh$toxicity, decreasing = TRUE)
      coh$dose <- max(coh$dose)
      coh
    })
  } else if (has_placebo) {
    # Placebo will be plotted at y = 0 level.
    df$dose[df$dose == pbo_dose] <- 0
  }
  df
}

# h_plot_data_df ----

## generic ----

#' Helper Function for the Plot Method of subclasses of [`GeneralData`]
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that transforms [`GeneralData`]  objects into a `tibble` suitable for
#' plotting with `ggplot2` methods
#'
#' @param data (`GeneralData`)\cr object from which data is extracted and converted
#' into a data frame.
#' @param ... further arguments passed to class-specific methods.
#' @return `data.frame` containing columns for patient, cohort, dose and toxicity grade
#' @aliases h_plot_data_df
#'
setGeneric(
  name = "h_plot_data_df",
  def = function(data, ...) standardGeneric("h_plot_data_df"),
  valueClass = "data.frame"
)

# Data ----

#' Helper Function for the Plot Method of [`Data`]
#'
#' @param data (`Data`)\cr object from which data is extracted and converted
#'   into a data frame.
#' @param blind (`flag`)\cr should data be blinded?
#'   If `TRUE`, then for each cohort, all DLTs are assigned to the first
#'   subjects in the cohort. In addition, the placebo (if any) is set to the
#'   active dose level for that cohort.
#' @param legend (`flag`)\cr Display the legend for the toxicity categories
#' @param ... further arguments passed to `data.frame` constructor.
#'   It can be e.g. an extra `column_name = value` pair based on a slot
#'   from `x` (which in this case might be a subclass of `Data`)
#'   which does not appear in `Data`.
#' @return A `data.frame` object with columns patient, ID, cohort, dose and
#' toxicity.
#' @describeIn h_plot_data_df method for [`Data`].
setMethod(
  f = "h_plot_data_df",
  signature = signature(data = "Data"),
  definition = function(data, blind = FALSE, legend = TRUE, ...) {
    df <- data.frame(
      patient = seq_along(data@x),
      ID = paste(" ", data@ID),
      cohort = data@cohort,
      dose = data@x,
      toxicity = ifelse(data@y == 1, "Yes", "No"),
      ...
    )
    df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
    df
  }
)

# DataOrdinal ----

#' Helper Function for the Plot Method of [`DataOrdinal`]
#'
#' @describeIn h_plot_data_df Class specific method for [`DataOrdinal`]
setMethod(
  f = "h_plot_data_df",
  signature = signature(data = "DataOrdinal"),
  definition = function(data, blind = FALSE, legend = TRUE, ...) {
    df <- data.frame(
      patient = seq_along(data@x),
      ID = paste(" ", data@ID),
      cohort = data@cohort,
      dose = data@x,
      toxicity = names(data@yCategories)[1 + data@y],
      ...
    )
    df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
    df
  }
)


# h_plot_data_dataordinal

## Data ----

#' Helper Function for the Plot Method of the Data and DataOrdinal Classes
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`Data`]  and [`DataOrdinal`] objects.
#'
#' @note The default values of `tox_shapes` and `tox_labels` result in DLTs
#' being displayed as red triangles and other responses as black circles.
#' @return The [`ggplot2`] object.
#'
#' @rdname plot-Data
h_plot_data_dataordinal <- function(
  x,
  blind = FALSE,
  legend = TRUE,
  tox_labels = c(Yes = "red", No = "black"),
  tox_shapes = c(Yes = 17L, No = 16L),
  ...
) {
  assert_flag(blind)
  assert_flag(legend)
  assert_character(tox_labels, any.missing = FALSE, unique = TRUE)
  assert_integer(tox_shapes, any.missing = FALSE, unique = TRUE)
  assert_true(length(tox_shapes) == length(tox_labels))
  assert_subset(x@y, as.integer(0:(length(tox_shapes) - 1)))
  if (x@nObs == 0L) {
    return()
  }
  df <- h_plot_data_df(x, blind, ...)

  p <- ggplot(df, aes(x = patient, y = dose)) +
    geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +
    scale_colour_manual(
      name = "Toxicity",
      values = tox_labels,
      breaks = names(tox_labels),
      guide = guide_legend(reverse = TRUE)
    ) +
    scale_shape_manual(
      name = "Toxicity",
      values = tox_shapes,
      breaks = names(tox_shapes),
      guide = guide_legend(reverse = TRUE)
    ) +
    scale_x_continuous(breaks = df$patient, minor_breaks = NULL) +
    scale_y_continuous(
      breaks = sort(unique(c(0, df$dose))),
      minor_breaks = NULL,
      limits = c(0, max(df$dose) * 1.1)
    ) +
    xlab("Patient") +
    ylab("Dose Level")

  p <- p + h_plot_data_cohort_lines(df$cohort, placebo = x@placebo)

  if (!blind) {
    p <- p +
      geom_text(
        aes(label = ID, size = 2),
        data = df,
        hjust = 0,
        vjust = 0.5,
        angle = 90,
        colour = "black",
        show.legend = FALSE
      )
  }

  if (!legend) {
    p <- p + theme(legend.position = "none")
  }

  p
}

#' Helper Function Containing Common Functionality
#'
#' Used by `dose_grid_range-Data` and `dose_grid_range-DataOrdinal`
#' @param object (`Data` or `DataOrdinal`)\cr the object for which the dose grid
#' range is required
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#'
h_obtain_dose_grid_range <- function(object, ignore_placebo) {
  assert_flag(ignore_placebo)

  dose_grid <- if (ignore_placebo && object@placebo && object@nGrid >= 1) {
    object@doseGrid[-1]
  } else {
    object@doseGrid
  }

  if (length(dose_grid) == 0L) {
    c(-Inf, Inf)
  } else {
    range(dose_grid)
  }
}

#' Convert a Ordinal Data to the Equivalent Binary Data for a Specific
#' Grade
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that takes a [`DataOrdinal`] object and an
#' integer grade and converts them to the equivalent `Data` object.
#'
#' @param data_ord (`DataOrdinal`)\cr the `DataOrdinal` object to covert
#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
#' is required.
#' @return A [`Data`] object.
#'
#' @export
h_convert_ordinal_data <- function(data_ord, grade) {
  # Validate
  assert_integer(grade, len = 1, lower = 1)
  assert_class(data_ord, "DataOrdinal")
  # Execute
  Data(
    ID = data_ord@ID,
    cohort = data_ord@cohort,
    x = data_ord@x,
    y = as.integer(data_ord@y >= grade),
    doseGrid = data_ord@doseGrid,
    nGrid = data_ord@nGrid,
    xLevel = data_ord@xLevel,
    placebo = data_ord@placebo
  )
}

#' @include Design-validity.R
#' @include Model-class.R
#' @include Rules-class.R
#' @include Data-class.R
#' @include helpers.R
#' @include CrmPackClass-class.R
NULL

# RuleDesign ----

## class ----

#' `RuleDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`RuleDesign`] is the class for rule-based designs. The difference between
#' this class and the [`Design`] class is that [`RuleDesign`] does not contain
#' `model`, `stopping` and `increments` slots.
#'
#' @slot nextBest (`NextBest`)\cr how to find the next best dose.
#' @slot cohort_size (`CohortSize`)\cr rules for the cohort sizes.
#' @slot data (`Data`)\cr specifies dose grid, any previous data, etc.
#' @slot startingDose (`number`)\cr the starting dose, it must lie on the dose
#'   grid in `data`.
#'
#' @aliases RuleDesign
#' @export
#'
.RuleDesign <- setClass(
  Class = "RuleDesign",
  slots = c(
    nextBest = "NextBest",
    cohort_size = "CohortSize",
    data = "Data",
    startingDose = "numeric"
  ),
  prototype = prototype(
    nextBest = .NextBestThreePlusThree(),
    cohort_size = CohortSizeConst(3),
    data = Data(doseGrid = 1:3),
    startingDose = 1
  ),
  contains = "CrmPackClass",
  validity = v_rule_design
)

## constructor ----

#' @rdname RuleDesign-class
#'
#' @param nextBest (`NextBest`)\cr see slot definition.
#' @param cohort_size (`CohortSize`)\cr see slot definition.
#' @param data (`Data`)\cr see slot definition.
#' @param startingDose (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Design-class-RuleDesign.R
#'
RuleDesign <- function(nextBest, cohort_size, data, startingDose) {
  new(
    "RuleDesign",
    nextBest = nextBest,
    cohort_size = cohort_size,
    data = data,
    startingDose = as.numeric(startingDose)
  )
}

#' @rdname RuleDesign-class
#' @note Typically, end users will not use the `.DefaultRuleDesign()` function.
#' @export

.DefaultRuleDesign <- function() {
  RuleDesign(
    nextBest = NextBestThreePlusThree(),
    cohort_size = CohortSizeConst(size = 3L),
    data = Data(doseGrid = c(5, 10, 15, 25, 35, 50, 80)),
    startingDose = 5
  )
}

## ThreePlusThreeDesign ----

#' @describeIn RuleDesign-class creates a new 3+3 design object from a dose grid.
#'
#' @param doseGrid (`numeric`)\cr the dose grid to be used (sorted).
#'
#' @export
#' @example examples/Design-class-ThreePlusThreeDesign.R
#'
ThreePlusThreeDesign <- function(doseGrid) {
  empty_data <- Data(doseGrid = doseGrid)

  # Using a constant cohort size of 3 we obtain exactly the 3+3 design.
  RuleDesign(
    nextBest = NextBestThreePlusThree(),
    data = empty_data,
    cohort_size = CohortSizeConst(size = 3L),
    startingDose = doseGrid[1]
  )
}

# Design ----

## class ----

#' `Design`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Design`] is the class for rule-based designs. The difference between
#' this class and its parent [`RuleDesign`] class is that [`Design`] class
#' contains additional `model`, `stopping` and `increments` slots.
#'
#' @slot model (`GeneralModel`)\cr the model to be used.
#' @slot stopping (`Stopping`)\cr stopping rule(s) for the trial.
#' @slot increments (`Increments`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSize`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases Design
#' @export
#'
.Design <- setClass(
  Class = "Design",
  slots = c(
    model = "GeneralModel",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize"
  ),
  prototype = prototype(
    model = .LogisticNormal(),
    nextBest = .NextBestNCRM(),
    stopping = .StoppingMinPatients(),
    increments = .IncrementsRelative(),
    pl_cohort_size = CohortSizeConst(0L)
  ),
  contains = "RuleDesign"
)

## constructor ----

#' @rdname Design-class
#'
#' @param model (`GeneralModel`)\cr see slot definition.
#' @param stopping (`Stopping`)\cr see slot definition.
#' @param increments (`Increments`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSize`)\cr see slot definition.
#' @inheritDotParams RuleDesign
#'
#' @export
#' @example examples/Design-class-Design.R
#'
#'
Design <- function(
  model,
  stopping,
  increments,
  pl_cohort_size = CohortSizeConst(0L),
  ...
) {
  start <- RuleDesign(...)
  new(
    "Design",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname Design-class
#' @note Typically, end users will not use the `.DefaultDesign()` function.
#' @export
.DefaultDesign <- function() {
  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- maxSize(my_size1, my_size2)

  my_stopping1 <- StoppingMinCohorts(nCohorts = 3)
  my_stopping2 <- StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
  my_stopping3 <- StoppingMinPatients(nPatients = 20)
  my_stopping <- (my_stopping1 & my_stopping2) | my_stopping3

  # Initialize the design.
  design <- Design(
    model = LogisticLogNormal(
      mean = c(-0.85, 1),
      cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
      ref_dose = 56
    ),
    nextBest = NextBestNCRM(
      target = c(0.2, 0.35),
      overdose = c(0.35, 1),
      max_overdose_prob = 0.25
    ),
    stopping = my_stopping,
    increments = IncrementsRelative(
      intervals = c(0, 20),
      increments = c(1, 0.33)
    ),
    cohort_size = my_size,
    data = Data(doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100)),
    startingDose = 3
  )
}

# DualDesign ----

## class ----

#' `DualDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DualDesign`] is the class for the dual-endpoint CRM design. This class has
#' special requirements for the `model` and `data` slots in comparison to the
#' parent class [`Design`].
#'
#' @note the `nextBest` slot can be of any class, this allows for easy comparison
#'   with recommendation methods that don't use the biomarker information.
#'
#' @slot model (`DualEndpoint`)\cr the model to be used.
#' @slot data (`DataDual`)\cr specifies dose grid, any previous data, etc.
#'
#' @aliases DualDesign
#' @export
#'
.DualDesign <- setClass(
  Class = "DualDesign",
  slots = c(
    model = "DualEndpoint",
    data = "DataDual"
  ),
  prototype = prototype(
    model = .DualEndpoint(),
    nextBest = .NextBestDualEndpoint(),
    data = DataDual(doseGrid = 1:2),
    startingDose = 1
  ),
  contains = "Design"
)

## constructor ----

#' @rdname DualDesign-class
#'
#' @param model (`DualEndpoint`)\cr see slot definition.
#' @param data (`DataDual`)\cr see slot definition.
#' @inheritDotParams Design
#'
#' @export
#' @example examples/Design-class-DualDesign.R
#'
DualDesign <- function(model, data, ...) {
  start <- Design(model = model, data = data, ...)
  new(
    "DualDesign",
    start,
    model = model,
    data = data
  )
}

## default constructor ----

#' @rdname DualDesign-class
#' @note Typically, end users will not use the `.DefaultDualDesign()` function.
#' @export
.DefaultDualDesign <- function() {
  my_model <- DualEndpointRW(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2betaW = 0.01,
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    rw1 = TRUE
  )

  # Choose the rule for selecting the next dose.
  my_next_best <- NextBestDualEndpoint(
    target = c(0.9, 1),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )

  # Choose the rule for the cohort-size.
  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- maxSize(my_size1, my_size2)

  # Choose the rule for stopping.
  my_stopping1 <- StoppingTargetBiomarker(
    target = c(0.9, 1),
    prob = 0.5
  )
  my_stopping <- my_stopping1 | StoppingMinPatients(40)

  # Choose the rule for dose increments.
  my_increments <- IncrementsRelative(
    intervals = c(0, 20),
    increments = c(1, 0.33)
  )

  # Initialize the design.
  DualDesign(
    model = my_model,
    data = DataDual(doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100)),
    nextBest = my_next_best,
    stopping = my_stopping,
    increments = my_increments,
    cohort_size = my_size,
    startingDose = 3
  )
}

# TDsamplesDesign ----

## class ----

#' `TDsamplesDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`TDsamplesDesign`] is the class of design based only on DLT responses using
#' [`ModelTox`] class model (i.e. [`LogisticIndepBeta`]) as well as MCMC samples
#' obtained for this model.
#'
#' @slot model (`ModelTox`)\cr the pseudo DLT model to be used.
#' @slot stopping (`Stopping`)\cr stopping rule(s) for the trial.
#' @slot increments (`Increments`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSize`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases TDsamplesDesign
#' @export
#'
.TDsamplesDesign <- setClass(
  Class = "TDsamplesDesign",
  slots = c(
    model = "ModelTox",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize"
  ),
  prototype = prototype(
    model = .LogisticIndepBeta(),
    nextBest = .NextBestTDsamples(),
    stopping = .StoppingMinPatients(),
    increments = .IncrementsRelative(),
    pl_cohort_size = CohortSizeConst(0L)
  ),
  contains = "RuleDesign"
)

## constructor ----

#' @rdname TDsamplesDesign-class
#'
#' @param model (`ModelTox`)\cr see slot definition.
#' @param stopping (`Stopping`)\cr see slot definition.
#' @param increments (`Increments`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSize`)\cr see slot definition.
#' @inheritDotParams RuleDesign
#'
#' @export
#' @example examples/Design-class-TDsamplesDesign.R
#'
TDsamplesDesign <- function(
  model,
  stopping,
  increments,
  pl_cohort_size = CohortSizeConst(0L),
  ...
) {
  start <- RuleDesign(...)
  new(
    "TDsamplesDesign",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname TDsamplesDesign-class
#' @note Typically, end users will not use the `.DefaultTDsamplesDesign()` function.
#' @export
.DefaultTDsamplesDesign <- function() {
  empty_data <- Data(doseGrid = seq(25, 300, 25))

  my_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3, 3),
    DLEdose = c(25, 300),
    data = empty_data
  )

  TDsamplesDesign(
    model = my_model,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = range(empty_data@doseGrid),
      increments = c(2, 2)
    ),
    nextBest = NextBestTDsamples(
      prob_target_drt = 0.35,
      prob_target_eot = 0.3,
      derive = function(samples) {
        as.numeric(quantile(samples, probs = 0.3))
      }
    ),
    cohort_size = CohortSizeConst(size = 3),
    data = empty_data,
    startingDose = 25
  )
}

# TDDesign ----

## class ----

#' `TDDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`TDDesign`] is the class of design based only on DLT responses using
#' [`ModelTox`] class model (i.e. [`LogisticIndepBeta`]) without MCMC samples.
#'
#' @slot model (`ModelTox`)\cr the pseudo DLT model to be used.
#' @slot stopping (`Stopping`)\cr stopping rule(s) for the trial.
#' @slot increments (`Increments`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSize`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases TDDesign
#' @export
#'
.TDDesign <- setClass(
  Class = "TDDesign",
  slots = c(
    model = "ModelTox",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize"
  ),
  prototype = prototype(
    model = .LogisticIndepBeta(),
    nextBest = .NextBestTD(),
    stopping = .StoppingMinPatients(),
    increments = .IncrementsRelative(),
    pl_cohort_size = CohortSizeConst(0L)
  ),
  contains = "RuleDesign"
)

## constructor ----

#' @rdname TDDesign-class
#'
#' @param model (`ModelTox`)\cr see slot definition.
#' @param stopping (`Stopping`)\cr see slot definition.
#' @param increments (`Increments`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSize`)\cr see slot definition.
#' @inheritDotParams RuleDesign
#'
#' @export
#' @example examples/Design-class-TDDesign.R
#'
TDDesign <- function(
  model,
  stopping,
  increments,
  pl_cohort_size = CohortSizeConst(0L),
  ...
) {
  start <- RuleDesign(...)
  new(
    "TDDesign",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname TDDesign-class
#' @note Typically, end users will not use the `.DefaultTDDesign()` function.
#' @export
.DefaultTDDesign <- function() {
  empty_data <- Data(doseGrid = seq(25, 300, 25))

  my_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3, 3),
    DLEdose = c(25, 300),
    data = empty_data
  )

  TDDesign(
    model = my_model,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = range(empty_data@doseGrid),
      increments = c(2, 2)
    ),
    nextBest = NextBestTD(
      prob_target_drt = 0.35,
      prob_target_eot = 0.3
    ),
    cohort_size = CohortSizeConst(size = 3),
    data = empty_data,
    startingDose = 25
  )
}

# DualResponsesSamplesDesign ----

## class ----

#' `DualResponsesSamplesDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a class of design based on DLE responses using the [`LogisticIndepBeta`] model
#  and efficacy responses using [`ModelEff`]  model class
#' with DLE and efficacy samples. It contain all slots in
#' [`RuleDesign`] and [`TDsamplesDesign`] class objects.
#
#' @slot data (`DataDual`)\cr the data set.
#' @slot eff_model (`ModelEff`)\cr the pseudo efficacy model to be used.
#'
#' @aliases DualResponsesSamplesDesign
#' @export
#'
.DualResponsesSamplesDesign <-
  setClass(
    Class = "DualResponsesSamplesDesign",
    slots = c(
      eff_model = "ModelEff",
      data = "DataDual"
    ),
    prototype = prototype(
      nextBest = .NextBestMaxGainSamples(),
      data = DataDual(doseGrid = 1:2),
      startingDose = 1,
      model = .LogisticIndepBeta()
    ),
    contains = "TDsamplesDesign"
  )

## constructor ----

#' @rdname DualResponsesSamplesDesign-class
#'
#' @param data (`DataDual`)\cr see slot definition.
#' @param eff_model (`ModelEff`)\cr see slot definition.
#' @inheritDotParams TDsamplesDesign
#'
#' @example examples/Design-class-DualResponsesSamplesDesign.R
#' @export
#'
DualResponsesSamplesDesign <- function(eff_model, data, ...) {
  start <- TDsamplesDesign(data = data, ...)
  .DualResponsesSamplesDesign(
    start,
    eff_model = eff_model,
    data = data
  )
}

## default constructor ----

#' @rdname DualResponsesSamplesDesign-class
#' @note Typically, end users will not use the `.DefaultDualResponsesSamplesDesign()` function.
#' @export
.DefaultDualResponsesSamplesDesign <- function() {
  empty_data <- DataDual(doseGrid = seq(25, 300, 25))

  tox_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3, 3),
    DLEdose = c(25, 300),
    data = empty_data
  )
  options <- McmcOptions(burnin = 100, step = 2, samples = 200)
  tox_samples <- mcmc(empty_data, tox_model, options)

  eff_model <- Effloglog(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    nu = c(a = 1, b = 0.025),
    data = empty_data
  )
  eff_samples <- mcmc(empty_data, eff_model, options)

  my_next_best <- NextBestMaxGainSamples(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(samples) {
      as.numeric(quantile(samples, prob = 0.3))
    },
    mg_derive = function(mg_samples) {
      as.numeric(quantile(mg_samples, prob = 0.5))
    }
  )

  DualResponsesSamplesDesign(
    nextBest = my_next_best,
    cohort_size = CohortSizeConst(size = 3),
    startingDose = 25,
    model = tox_model,
    eff_model = eff_model,
    data = empty_data,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = c(25, 300),
      increments = c(2, 2)
    )
  )
}

# DualResponsesDesign.R ----

## class ----

#' `DualResponsesDesign.R`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a class of design based on DLE responses using the [`LogisticIndepBeta`] model
#  and efficacy responses using the [`ModelEff`]  model class
#' without DLE and efficacy samples. It contains all slots from the
#' [`RuleDesign`] and [`TDsamplesDesign`] classes.
#
#' @slot data (`DataDual`)\cr the data set.
#' @slot eff_model (`ModelEff`)\cr the pseudo efficacy model to be used.
#'
#' @aliases DualResponsesDesign
#' @export
#'
.DualResponsesDesign <-
  setClass(
    Class = "DualResponsesDesign",
    slots = c(
      eff_model = "ModelEff",
      data = "DataDual"
    ),
    prototype = prototype(
      nextBest = .NextBestMaxGain(),
      data = DataDual(doseGrid = 1:2),
      startingDose = 1,
      model = .LogisticIndepBeta()
    ),
    contains = "TDDesign"
  )

## constructor ----

#' @rdname DualResponsesDesign-class
#'
#' @param data (`DataDual`)\cr see slot definition.
#' @param eff_model (`ModelEff`)\cr see slot definition.
#' @inheritDotParams TDDesign
#'
#' @example examples/Design-class-DualResponsesDesign.R
#' @export
#'
DualResponsesDesign <- function(eff_model, data, ...) {
  start <- TDDesign(data = data, ...)
  .DualResponsesDesign(
    start,
    eff_model = eff_model,
    data = data
  )
}

## default constructor ----

#' @rdname DualResponsesDesign-class
#' @note Typically, end users will not use the `.DefaultDualResponsesDesign()` function.
#' @export
.DefaultDualResponsesDesign <- function() {
  empty_data <- DataDual(doseGrid = seq(25, 300, 25))

  DualResponsesDesign(
    nextBest = NextBestMaxGain(
      prob_target_drt = 0.35,
      prob_target_eot = 0.3
    ),
    cohort_size = CohortSizeConst(size = 3),
    startingDose = 25,
    model = LogisticIndepBeta(
      binDLE = c(1.05, 1.8),
      DLEweights = c(3, 3),
      DLEdose = c(25, 300),
      data = empty_data
    ),
    eff_model = Effloglog(
      eff = c(1.223, 2.513),
      eff_dose = c(25, 300),
      nu = c(a = 1, b = 0.025),
      data = empty_data
    ),
    data = empty_data,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = c(25, 300),
      increments = c(2, 2)
    )
  )
}


# DADesign ----

## class ----

#' `DADesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class has special requirements for the `model` and `data`
#' slots in comparison to the parent class [`Design`]:
#'
#' @slot model (`GeneralModel`)\cr the model to use, see in particular [`DALogisticLogNormal`] and
#' [`TITELogisticLogNormal`] which make use of the time-to-DLT data.
#' @slot data (`DataDA`)\cr what is the dose grid, any previous data, etc.
#' @slot safetyWindow (`SafetyWindow`)\cr the safety window to apply between cohorts.
#'
#' @details
#' The `safetyWindow` slot should be an instance of the `SafetyWindow` class.
#' It can be customized to specify the duration of the safety window for your trial.
#' The safety window represents the time period required to observe toxicity data
#' from the ongoing cohort before opening the next cohort.
#' Note that even after opening the next cohort,
#' further toxicity data will be collected and analyzed to make dose escalation decisions.
#'
#'
#' To specify a constant safety window, use the `SafetyWindowConst` constructor. For example:
#'
#' \code{mysafetywindow <- SafetyWindowConst(c(6, 2), 10, 20)}
#'
#' @seealso [`SafetyWindowConst`] for creating a constant safety window.
#'
#' @aliases DADesign
#' @export
#'
.DADesign <-
  setClass(
    Class = "DADesign",
    slots = c(
      model = "GeneralModel",
      data = "DataDA",
      safetyWindow = "SafetyWindow"
    ),
    prototype = prototype(
      model = .DALogisticLogNormal(),
      nextBest = .NextBestNCRM(),
      data = DataDA(doseGrid = 1:2),
      safetyWindow = .SafetyWindowConst()
    ),
    contains = "Design"
  )


## constructor ----

#' @rdname DADesign-class
#'
#' @param model (`GeneralModel`)\cr see slot definition.
#' @param data (`DataDA`)\cr see slot definition.
#' @param safetyWindow (`SafetyWindow`)\cr see slot definition.
#' @inheritDotParams Design
#'
#' @example examples/Design-class-DADesign.R
#' @export
#'
DADesign <- function(model, data, safetyWindow, ...) {
  start <- Design(
    data = data,
    model = model,
    ...
  )
  .DADesign(start, safetyWindow = safetyWindow)
}

## default constructor ----

#' @rdname DADesign-class
#' @note Typically, end users will not use the `.DefaultDADesign()` function.
#' @export
.DefaultDADesign <- function() {
  emptydata <- DataDA(
    doseGrid = c(0.1, 0.5, 1, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    Tmax = 60
  )

  npiece_ <- 10
  t_max_ <- 60

  lambda_prior <- function(k) {
    npiece_ / (t_max_ * (npiece_ - k + 0.5))
  }

  model <- DALogisticLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 56,
    npiece = npiece_,
    l = as.numeric(t(apply(
      as.matrix(c(1:npiece_), 1, npiece_),
      2,
      lambda_prior
    ))),
    c_par = 2
  )

  mySize1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  mySize2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  mySize <- maxSize(mySize1, mySize2)

  myStopping1 <- StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
  myStopping2 <- StoppingMinPatients(nPatients = 50)
  myStopping <- (myStopping1 | myStopping2)

  DADesign(
    model = model,
    increments = IncrementsRelative(
      intervals = c(0, 20),
      increments = c(1, 0.33)
    ),
    nextBest = NextBestNCRM(
      target = c(0.2, 0.35),
      overdose = c(0.35, 1),
      max_overdose_prob = 0.25
    ),
    stopping = myStopping,
    cohort_size = mySize,
    data = emptydata,
    safetyWindow = SafetyWindowConst(c(6, 2), 7, 7),
    startingDose = 3
  )
}
# DesignGrouped ----

## class ----

#' `DesignGrouped`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DesignGrouped`] combines two [`Design`] objects: one for the mono and one
#' for the combo arm of a joint dose escalation design.
#'
#' @slot model (`LogisticLogNormalGrouped`)\cr the model to be used, currently only one
#'   class is allowed.
#' @slot mono (`Design`)\cr defines the dose escalation rules for the mono arm, see
#'   details.
#' @slot combo (`Design`)\cr defines the dose escalation rules for the combo arm, see
#'   details.
#' @slot first_cohort_mono_only (`flag`)\cr whether first test one mono agent cohort, and then
#'   once its DLT data has been collected, we proceed from the second cohort onwards with
#'   concurrent mono and combo cohorts.
#' @slot same_dose_for_all (`flag`)\cr whether the lower dose of the separately determined mono and combo
#'   doses should be used as the next dose for both mono and combo in all cohorts.
#' @slot same_dose_for_start (`flag`)\cr indicates whether, when mono and combo are
#'   used in the same cohort for the first time, the same dose should be used for both.
#'   Note that this is different from `same_dose_for_all` which will always force
#'   them to be the same. If `same_dose_for_all = TRUE`, this is therefore ignored. See Details.
#'
#' @details
#'
#'   - Note that the model slots inside the `mono` and `combo` parameters
#'     are ignored (because we don't fit separate regression models for the mono and
#'     combo arms). Instead, the `model` parameter is used to fit a joint regression
#'     model for the mono and combo arms together.
#'   - `same_dose_for_start = TRUE` is useful as an option when we want to use `same_dose_for_all = FALSE`
#'     combined with `first_cohort_mono_only = TRUE`.
#'     This will allow to randomize patients to the mono and combo arms at the same dose
#'     as long as the selected dose for the cohorts stay the same. This can therefore
#'     further mitigate bias as long as possible between the mono and combo arms.
#'
#' @aliases DesignGrouped
#' @export
#'
.DesignGrouped <- setClass(
  Class = "DesignGrouped",
  slots = c(
    model = "LogisticLogNormalGrouped",
    mono = "Design",
    combo = "Design",
    first_cohort_mono_only = "logical",
    same_dose_for_all = "logical",
    same_dose_for_start = "logical"
  ),
  prototype = prototype(
    model = .DefaultLogisticLogNormalGrouped(),
    mono = .Design(),
    combo = .Design(),
    first_cohort_mono_only = TRUE,
    same_dose_for_all = TRUE,
    same_dose_for_start = FALSE
  ),
  validity = v_design_grouped,
  contains = "CrmPackClass"
)

## constructor ----

#' @rdname DesignGrouped-class
#'
#' @param model (`LogisticLogNormalGrouped`)\cr see slot definition.
#' @param mono (`Design`)\cr see slot definition.
#' @param combo (`Design`)\cr see slot definition.
#' @param first_cohort_mono_only (`flag`)\cr see slot definition.
#' @param same_dose_for_all (`flag`)\cr see slot definition.
#' @param same_dose_for_start (`flag`)\cr see slot definition.
#' @param stop_mono_with_combo (`flag`)\cr whether the mono arm should be stopped when the combo
#'   arm is stopped (this makes sense when the only real trial objective is the recommended combo dose).
#' @param ... not used.
#'
#' @export
#' @example examples/Design-class-DesignGrouped.R
#'
DesignGrouped <- function(
  model,
  mono,
  combo = mono,
  first_cohort_mono_only = TRUE,
  same_dose_for_all = !same_dose_for_start,
  same_dose_for_start = FALSE,
  stop_mono_with_combo = FALSE,
  ...
) {
  assert_flag(stop_mono_with_combo)
  assert_class(mono, "Design")
  force(combo)
  if (stop_mono_with_combo) {
    mono@stopping <- mono@stopping |
      StoppingExternal(report_label = "Stop Mono with Combo")
  }

  .DesignGrouped(
    model = model,
    mono = mono,
    combo = combo,
    first_cohort_mono_only = first_cohort_mono_only,
    same_dose_for_all = same_dose_for_all,
    same_dose_for_start = same_dose_for_start
  )
}

## default constructor ----

#' @rdname DesignGrouped-class
#' @note Typically, end-users will not use the `.DefaultDesignGrouped()` function.
#' @export
.DefaultDesignGrouped <- .DesignGrouped

# RuleDesignOrdinal ----

## class ----

#' `RuleDesignOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`RuleDesignOrdinal`] is the class for rule-based designs. The difference between
#' this class and the [`DesignOrdinal`] class is that [`RuleDesignOrdinal`]
#' does not contain `model`, `stopping` and `increments` slots.
#'
#' @slot next_best (`NextBestOrdinal`)\cr how to find the next best dose.
#' @slot cohort_size (`CohortSizeOrdinal`)\cr rules for the cohort sizes.
#' @slot data (`DataOrdinal`)\cr specifies dose grid, any previous data, etc.
#' @slot starting_dose (`number`)\cr the starting dose, it must lie on the dose
#'   grid in `data`.
#'
#' @aliases RuleDesignOrdinal
#' @export
#'
.RuleDesignOrdinal <- setClass(
  Class = "RuleDesignOrdinal",
  slots = c(
    next_best = "NextBestOrdinal",
    cohort_size = "CohortSizeOrdinal",
    data = "DataOrdinal",
    starting_dose = "numeric"
  ),
  prototype = prototype(
    next_best = .NextBestOrdinal(),
    cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(3L)),
    data = DataOrdinal(doseGrid = 1:3),
    starting_dose = 1
  ),
  contains = "CrmPackClass",
  validity = v_rule_design_ordinal
)

## constructor ----

#' @rdname RuleDesignOrdinal-class
#'
#' @param next_best (`NextBestOrdinal`)\cr see slot definition.
#' @param cohort_size (`CohortSizeOrdinal`)\cr see slot definition.
#' @param data (`DataOrdinal`)\cr see slot definition.
#' @param starting_dose (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Design-class-RuleDesignOrdinal.R
#'
RuleDesignOrdinal <- function(
  next_best,
  cohort_size,
  data,
  starting_dose
) {
  new(
    "RuleDesignOrdinal",
    next_best = next_best,
    cohort_size = cohort_size,
    data = data,
    starting_dose = as.numeric(starting_dose)
  )
}

#' @rdname RuleDesignOrdinal-class
#' @note Typically, end users will not use the `.DefaultRuleDesignOrdinal()` function.
#' @export

.DefaultRuleDesignOrdinal <- function() {
  RuleDesignOrdinal(
    next_best = NextBestOrdinal(
      1L,
      NextBestMTD(target = 0.25, derive = function(x) mean(x, na.rm = TRUE))
    ),
    cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(size = 3L)),
    data = DataOrdinal(doseGrid = c(5, 10, 15, 25, 35, 50, 80)),
    starting_dose = 5
  )
}

# DesignOrdinal ----

## class ----

#' `DesignOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DesignOrdinal`] is the class for rule-based ordinal designs. The difference
#' between this class and its parent [`RuleDesignOrdinal`] class is that the
#'  [`DesignOrdinal`] class contains additional `model`, `stopping`,
#'  `increments` and `pl_cohort_size` slots.
#'
#' @slot model (`LogisticLogNormalOrdinal`)\cr the model to be used.
#' @slot stopping (`StoppingOrdinal`)\cr stopping rule(s) for the trial.
#' @slot increments (`IncrementsOrdinal`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSizeOrdinal`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases DesignOrdinal
#' @export
#'
.DesignOrdinal <- setClass(
  Class = "DesignOrdinal",
  slots = c(
    model = "LogisticLogNormalOrdinal",
    stopping = "StoppingOrdinal",
    increments = "IncrementsOrdinal",
    pl_cohort_size = "CohortSizeOrdinal"
  ),
  prototype = prototype(
    model = .LogisticLogNormalOrdinal(),
    next_best = .NextBestOrdinal(),
    stopping = .StoppingOrdinal(),
    increments = .IncrementsOrdinal(),
    pl_cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(3L))
  ),
  contains = "RuleDesignOrdinal"
)

## constructor ----

#' @rdname DesignOrdinal-class
#'
#' @param model (`LogisticLogNormalOrdinal`)\cr see slot definition.
#' @param stopping (`StoppingOrdinal`)\cr see slot definition.
#' @param increments (`IncrementsOrdinal`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSizeOrdinal`)\cr see slot definition.
#' @inheritDotParams RuleDesignOrdinal
#'
#' @export
#' @example examples/Design-class-DesignOrdinal.R
#'
#'
DesignOrdinal <- function(
  model,
  stopping,
  increments,
  pl_cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(0L)),
  ...
) {
  start <- RuleDesignOrdinal(...)
  new(
    "DesignOrdinal",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname DesignOrdinal-class
#' @note Typically, end users will not use the `.DefaultDesignOrdinal()` function.
#' @export
.DefaultDesignOrdinal <- function() {
  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- CohortSizeOrdinal(1L, maxSize(my_size1, my_size2))

  my_stopping1 <- StoppingMinCohorts(nCohorts = 3)
  my_stopping2 <- StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
  my_stopping3 <- StoppingMinPatients(nPatients = 20)
  my_stopping <- StoppingOrdinal(
    1L,
    (my_stopping1 & my_stopping2) | my_stopping3
  )

  # Initialize the design.
  design <- DesignOrdinal(
    model = LogisticLogNormalOrdinal(
      mean = c(-3, -4, 1),
      cov = diag(c(3, 4, 1)),
      ref_dose = 50
    ),
    next_best = NextBestOrdinal(
      1L,
      NextBestNCRM(
        target = c(0.2, 0.35),
        overdose = c(0.35, 1),
        max_overdose_prob = 0.25
      )
    ),
    stopping = my_stopping,
    increments = IncrementsOrdinal(
      1L,
      IncrementsRelative(
        intervals = c(0, 20),
        increments = c(1, 0.33)
      )
    ),
    cohort_size = my_size,
    data = DataOrdinal(
      doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
      yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L)
    ),
    starting_dose = 3
  )
}

#' @include helpers_knitr_CohortSize.R

# Increments ----

#' Render a `IncrementsRelative` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed to [knitr::kable()]
#' @inheritParams knit_print.CohortSizeConst
#' @section Usage Notes:
#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
#' of `caption` is `"Defined by highest dose administered so far"`.  These
#' values can be overridden by passing `col.names` and `caption` in the function
#' call.
#' @export
#' @method knit_print IncrementsRelative
#' @rdname knit_print
knit_print.IncrementsRelative <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Min", "Max", "Increment")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- "Defined by highest dose administered so far"
  }
  x <- tidy(x)
  param[["x"]] <- x
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    c("Dose" = 2, " " = 1)
  )
  rv <- paste0(rv, "\n\n")

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsRelativeDLT` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed to [knitr::kable()]
#' @inheritParams knit_print.CohortSizeConst
#' @section Usage Notes:
#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
#' of `caption` is `"Defined by number of DLTs reported so far"`. These values
#' can be overridden by passing `col.names` and `caption` in the function call.
#' @export
#' @method knit_print IncrementsRelativeDLT
#' @rdname knit_print
knit_print.IncrementsRelativeDLT <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Min", "Max", "Increment")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- "Defined by number of DLTs reported so far"
  }

  param[["x"]] <- tidy(x)
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    c("No DLTs" = 2, " " = 1)
  )
  rv <- paste0(rv, "\n\n")

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsDoseLevels` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @inheritParams knit_print.CohortSizeConst
#' @export
#' @rdname knit_print
#' @method knit_print IncrementsDoseLevels
knit_print.IncrementsDoseLevels <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    "The maximum increment between cohorts is ",
    x@levels,
    ifelse(x@levels == 1, " level", " levels"),
    " relative to the ",
    ifelse(
      x@basis_level == "last",
      "dose used in the previous cohort.",
      "highest dose used so far."
    ),
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsHSRBeta` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @inheritParams knit_print.CohortSizeConst
#' @export
#' @method knit_print IncrementsHSRBeta
#' @rdname knit_print
knit_print.IncrementsHSRBeta <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    "The maximum increment is defined by a hard safety rule, independent of the CRM model, ",
    " and based on a beta(",
    x@a,
    ", ",
    x@b,
    ") ",
    "prior with a target toxicity rate of ",
    x@target,
    " and a probability threshold of ",
    x@prob,
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsMin` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` methods of the constituent
#' rules
#' @inheritParams knit_print.CohortSizeConst
#' @export
#' @method knit_print IncrementsMin
#' @rdname knit_print
knit_print.IncrementsMin <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    "The minimum of the increments defined in the following rules:",
    paste0(
      lapply(
        x@increments_list,
        function(x, ...) {
          knit_print(x, asis = asis, ...)
        }
      ),
      collapse = "\n"
    ),
    "\n\n",
    paste = "\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsOrdinal` object
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` method of the standard rule
#' @inheritParams knit_print.CohortSizeConst
#' @export
#' @method knit_print IncrementsOrdinal
#' @rdname knit_print
knit_print.IncrementsOrdinal <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    "Based on a toxicity grade of ",
    x@grade,
    ": ",
    paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n"),
    "\n\n",
    paste = "\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsRelativeParts` object
#'
#' @inherit knit_print.CohortSizeConst return
#' @param tox_label (`character`)\cr The word used to describe toxicities.  See
#' Usage Notes below.
#' @inheritParams knit_print.CohortSizeConst
#' @section Usage Notes:
#' `label` defines how toxicities are described.
#'
#' It should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a single toxicity and the second describes all other
#' toxicity counts.  If of length 1, the character `s` is appended to the value
#' describing a single toxicity.
#'
#' @export
#' @method knit_print IncrementsRelativeParts
#' @rdname knit_print
knit_print.IncrementsRelativeParts <- function(
  x,
  ...,
  asis = TRUE,
  tox_label = c("toxicity", "toxicities")
) {
  assert_flag(asis)

  tox_label <- h_prepare_labels(tox_label)
  rv <- paste0(
    "The maximum increment in Part 1 is defined by the `part1Ladder` slot of ",
    "the associated `DataParts` object.\n\n",
    "If no ",
    tox_label[2],
    " are reported in Part 1, the starting dose for Part 2 ",
    "will be ",
    ifelse(
      x@clean_start == 0,
      "the highest dose used in Part 1.\n\n",
      paste0(
        x@clean_start,
        ifelse(abs(x@clean_start) == 1, " dose ", " doses "),
        ifelse(x@clean_start < 0, "below ", "above "),
        "the highest dose used in Part 1.\n\n"
      )
    ),
    "If one or more ",
    tox_label[2],
    " are reported in Part 1, the starting dose for Part 2 ",
    "will be ",
    ifelse(
      x@dlt_start == 0,
      "the highest dose used in Part 1.\n\n",
      paste0(
        abs(x@dlt_start),
        ifelse(abs(x@dlt_start) == 1, " dose ", " doses "),
        ifelse(x@dlt_start < 0, "below ", "above "),
        "the highest dose used in Part 1.\n\n"
      )
    ),
    "Once Part 2 has started, the maximum increment in dose levels will be based ",
    "on the number of ",
    tox_label[2],
    " reported so far, as described in the ",
    "following table:"
  )

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Lower", "Upper", "Increment")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- paste0(
      "Defined by the number of ",
      tox_label[2],
      " reported so far"
    )
  }
  header <- c(2, 1)
  headerLabel <- tox_label[2]
  substr(headerLabel, 1, 1) <- toupper(substr(headerLabel, 1, 1))
  names(header) <- c(headerLabel, " ")
  param[["x"]] <- tibble(
    intervals = x@intervals
  ) %>%
    h_range_to_minmax(intervals) %>%
    tibble::add_column(increments = c(0, x@increments))
  d_tab <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    header
  )
  rv <- paste(rv, d_tab, "\n\n")
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsRelativeDLTCurrent` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param tox_label (`character`)\cr The word used to describe toxicities.  See
#' Usage Notes below.
#' @param ... passed to [knitr::kable()]
#' @inheritParams knit_print.CohortSizeConst
#' @section Usage Notes:
#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
#' of `caption` is `"Defined by number of DLTs in the current cohort"`. These values
#' can be overridden by passing `col.names` and `caption` in the function call.
#'
#' `tox_label` defines how toxicities are described.
#'
#' It should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a single toxicity and the second describes all other
#' toxicity counts.  If of length 1, the character `s` is appended to the value
#' describing a single toxicity.
#'
#' @export
#' @method knit_print IncrementsRelativeDLTCurrent
#' @rdname knit_print
knit_print.IncrementsRelativeDLTCurrent <- function(
  x,
  ...,
  asis = TRUE,
  tox_label = c("DLT", "DLTs")
) {
  assert_flag(asis)
  assert_character(tox_label, min.len = 1, max.len = 2, any.missing = FALSE)

  if (length(tox_label) == 1) {
    tox_label[2] <- paste0(tox_label[1], "s")
  }

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Min", "Max", "Increment")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- paste0(
      "Defined by number of ",
      tox_label[2],
      " reported in the current cohort"
    )
  }
  param[["x"]] <- tidy(x)
  header_text <- c(2, 1)
  names(header_text) <- c(paste0("No ", tox_label[2]), " ")
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    header_text
  )
  rv <- paste0(rv, "\n\n")

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @include helpers.R
#' @include Data-class.R
#' @include Simulations-validity.R
#' @include CrmPackClass-class.R
NULL

# GeneralSimulations ----

## class ----

#' `GeneralSimulations` @description `r lifecycle::badge("stable")`
#' This class captures trial simulations.
#' Here also the random generator state before starting the simulation is
#' saved, in order to be able to reproduce the outcome. For this just use
#' [`set.seed`] with the `seed` as argument before running
#' [`simulate,Design-method`].
#'
#' @slot data (`list`)\cr produced [`Data`] objects.
#' @slot doses (`numeric`)\cr final dose recommendations.
#' @slot seed (`integer`)\cr random generator state before starting the simulation.
#'
#' @aliases GeneralSimulations
#' @export
.GeneralSimulations <-
  setClass(
    Class = "GeneralSimulations",
    slots = c(
      data = "list",
      doses = "numeric",
      seed = "integer"
    ),
    prototype = prototype(
      data = list(
        Data(
          x = 1:2,
          y = 0:1,
          doseGrid = 1:2,
          ID = 1L:2L,
          cohort = 1L:2L
        ),
        Data(
          x = 3:4,
          y = 0:1,
          doseGrid = 3:4,
          ID = 1L:2L,
          cohort = 1L:2L
        )
      ),
      doses = c(1, 2),
      seed = 1L
    ),
    contains = "CrmPackClass",
    validity = v_general_simulations
  )

## constructor ----

#' @rdname GeneralSimulations-class
#'
#' @param data (`list`)\cr see slot definition.
#' @param doses (`numeric`)\cr see slot definition.
#' @param seed (`integer`)\cr see slot definition.
#'
#' @example examples/Simulations-class-GeneralSimulations.R
#' @export
GeneralSimulations <- function(data, doses, seed) {
  assert_integerish(seed)
  .GeneralSimulations(
    data = data,
    doses = doses,
    seed = as.integer(seed)
  )
}


## default constructor

#' @rdname GeneralSimulations-class
#' @note Typically, end users will not use the `.DefaultGeneralSimulations()` function.
#' @export
.DefaultGeneralSimulations <- function() {
  GeneralSimulations(
    data = list(
      Data(x = 1:3, y = c(0, 1, 0), doseGrid = 1:3, ID = 1L:3L, cohort = 1L:3L),
      Data(x = 4:6, y = c(0, 1, 0), doseGrid = 4:6, ID = 1L:3L, cohort = 1L:3L)
    ),
    doses = c(1, 2),
    seed = 123
  )
}


# Simulations ----

## class ----

#' `Simulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the trial simulations from model based designs.
#' Additional slots `fit`, `stop_reasons`, `stop_report`,`additional_stats` compared to
#' the general class [`GeneralSimulations`].
#'
#' @slot fit (`list`)\cr final fits
#' @slot stop_reasons (`list`)\cr stopping reasons for each simulation run
#' @slot stop_report matrix of stopping rule outcomes
#' @slot additional_stats list of additional statistical summary
#' @aliases Simulations
#' @export
.Simulations <-
  setClass(
    Class = "Simulations",
    slots = c(
      fit = "list",
      stop_report = "matrix",
      stop_reasons = "list",
      additional_stats = "list"
    ),
    prototype = prototype(
      fit = list(
        c(0.1, 0.2),
        c(0.1, 0.2)
      ),
      stop_report = matrix(TRUE, nrow = 2),
      stop_reasons = list("A", "A"),
      additional_stats = list(a = 1, b = 1)
    ),
    contains = "GeneralSimulations",
    validity = v_simulations
  )

## constructor ----

#' @rdname Simulations-class
#'
#' @param fit (`list`)\cr see slot definition.
#' @param stop_reasons (`list`)\cr see slot definition.
#' @param stop_report see [`Simulations`]
#' @param additional_stats (`list`)\cr see slot definition.
#' @param \dots additional parameters from [`GeneralSimulations`]
#'
#' @example examples/Simulations-class-Simulations.R
#' @export
Simulations <- function(fit, stop_reasons, stop_report, additional_stats, ...) {
  start <- GeneralSimulations(...)
  .Simulations(
    start,
    fit = fit,
    stop_report = stop_report,
    stop_reasons = stop_reasons,
    additional_stats = additional_stats
  )
}

## default constructor ----

#' @rdname Simulations-class
#' @note Typically, end users will not use the `.DefaultSimulations()` function.
#' @export
.DefaultSimulations <- function() {
  design <- .DefaultDesign()
  myTruth <- probFunction(design@model, alpha0 = 7, alpha1 = 8)

  simulate(
    design,
    args = NULL,
    truth = myTruth,
    nsim = 1,
    seed = 819,
    mcmcOptions = .DefaultMcmcOptions(),
    parallel = FALSE
  )
}

# DualSimulations ----

## class ----

#' `DualSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the trial simulations from dual-endpoint model based
#' designs. In comparison to the parent class [`Simulations`],
#' it contains additional slots to capture the dose-biomarker `fits`, and the
#' `sigma2W` and `rho` estimates.
#'
#' @slot rho_est (`numeric`)\cr vector of final posterior median rho estimates
#' @slot sigma2w_est (`numeric`)\cr vector of final posterior median sigma2W estimates
#' @slot fit_biomarker (`list`)\cr with the final dose-biomarker curve fits
#' @aliases DualSimulations
#' @export
.DualSimulations <-
  setClass(
    Class = "DualSimulations",
    slots = c(
      rho_est = "numeric",
      sigma2w_est = "numeric",
      fit_biomarker = "list"
    ),
    prototype = prototype(
      rho_est = c(0.2, 0.3),
      sigma2w_est = c(0.2, 0.3),
      fit_biomarker = list(
        c(0.1, 0.2),
        c(0.1, 0.2)
      )
    ),
    contains = "Simulations",
    validity = v_dual_simulations
  )


## constructor ----

#' @rdname DualSimulations-class
#'
#' @param rho_est (`numeric`)\cr see [`DualSimulations`]
#' @param sigma2w_est (`numeric`)\cr [`DualSimulations`]
#' @param fit_biomarker (`list`)\cr see [`DualSimulations`]
#' @param \dots additional parameters from [`Simulations`]
#'
#' @example examples/Simulations-class-DualSimulations.R
#' @export
DualSimulations <- function(rho_est, sigma2w_est, fit_biomarker, ...) {
  start <- Simulations(...)
  .DualSimulations(
    start,
    rho_est = rho_est,
    sigma2w_est = sigma2w_est,
    fit_biomarker = fit_biomarker
  )
}

## default constructor ----

#' @rdname DualSimulations-class
#' @note Typically, end users will not use the `.DefaultDualSimulations()` function.
#' @export
.DefaultDualSimulations <- function() {
  DualSimulations(
    rho_est = c(0.25, 0.35),
    sigma2w_est = c(0.15, 0.25),
    fit_biomarker = list(c(0.3, 0.4), c(0.4, 0.5)),
    fit = list(
      c(0.1, 0.2),
      c(0.3, 0.4)
    ),
    stop_report = matrix(c(TRUE, FALSE), nrow = 2),
    stop_reasons = list("A", "B"),
    additional_stats = list(a = 1, b = 1),
    data = list(
      Data(
        x = 1:2,
        y = 0:1,
        doseGrid = 1:2,
        ID = 1L:2L,
        cohort = 1L:2L
      ),
      Data(
        x = 3:4,
        y = 0:1,
        doseGrid = 3:4,
        ID = 1L:2L,
        cohort = 1L:2L
      )
    ),
    doses = c(1, 2),
    seed = 123L
  )
}

#' `GeneralSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the summary of general simulations output. Note that objects
#' should not be created by users, therefore no initialization
#' function is provided for this class.
#'
#' @slot target (`numeric`)\cr target toxicity interval
#' @slot target_dose_interval (`numeric`)\cr corresponding target dose interval
#' @slot nsim (`integer`)\cr number of simulations
#' @slot prop_dlts (`ANY`)\cr A numeric array (multi-dimensional) or list representing proportions of DLTs in the trials
#' @slot mean_tox_risk (`numeric`)\cr mean toxicity risks for the patients
#' @slot dose_selected (`numeric`)\cr doses selected as MTD
#' @slot tox_at_doses_selected (`numeric`)\cr true toxicity at doses selected
#' @slot prop_at_target (`numeric`)\cr Proportion of trials selecting target MTD
#' @slot dose_most_selected (`numeric`)\cr dose most often selected as MTD
#' @slot obs_tox_rate_at_dose_most_selected (`numeric`)\cr observed toxicity rate at dose most often selected
#' @slot n_obs (`ANY`)\cr A numeric array (multi-dimensional) or list representing number of patients overall.
#' @slot n_above_target (`integer`)\cr number of patients treated above target tox interval
#' @slot dose_grid (`numeric`)\cr the dose grid that has been used
#' @slot placebo (`logical`)\cr set to TRUE (default is FALSE) for a design with placebo
#' @aliases GeneralSimulationsSummary
#' @export
.GeneralSimulationsSummary <-
  setClass(
    Class = "GeneralSimulationsSummary",
    slots = c(
      target = "numeric",
      target_dose_interval = "numeric",
      nsim = "integer",
      prop_dlts = "ANY",
      mean_tox_risk = "numeric",
      dose_selected = "numeric",
      tox_at_doses_selected = "numeric",
      prop_at_target = "numeric",
      dose_most_selected = "numeric",
      obs_tox_rate_at_dose_most_selected = "numeric",
      n_obs = "ANY",
      n_above_target = "integer",
      dose_grid = "numeric",
      placebo = "logical"
    )
  )

## default constructor ----

#' @rdname GeneralSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultGeneralSimulationsSummary()` function.
#' @export
.DefaultGeneralSimulationsSummary <- function() {
  stop(
    paste(
      "Class GeneralSimulationsSummary cannot be instantiated directly.",
      "Please use one of its subclasses instead."
    )
  )
}

## SimulationsSummary ----

## class ----

#' `SimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' In addition to the slots in the parent class [`GeneralSimulationsSummary`],
#' it contains two slots with model fit information.
#'
#' @slot stop_report (`matrix`)\cr matrix of stopping rule outcomes
#' @slot fit_at_dose_most_selected (`numeric`)\cr fitted toxicity rate at dose most often selected
#' @slot additional_stats (`list`)\cr list of additional statistical summary
#' @slot mean_fit (`list`)\cr list with the average, lower (2.5%) and upper (97.5%)
#' quantiles of the mean fitted toxicity at each dose level
#'
#' @aliases SimulationsSummary
#' @export
.SimulationsSummary <-
  setClass(
    Class = "SimulationsSummary",
    slots = c(
      stop_report = "matrix",
      fit_at_dose_most_selected = "numeric",
      additional_stats = "list",
      mean_fit = "list"
    ),
    contains = "GeneralSimulationsSummary"
  )

## default constructor ----

#' @rdname SimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultSimulationsSummary()` function.
#' @export
.DefaultSimulationsSummary <- function() {
  stop(paste(
    "Class SimulationsSummary cannot be instantiated directly.",
    "Please use one of its subclasses instead."
  ))
}

# DualSimulationsSummary ----

# class ----

#' `DualSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#' This class captures the summary of dual-endpoint simulations output.
#' In comparison to its parent class [`SimulationsSummary`], it has additional slots.
#'
#' @slot biomarker_fit_at_dose_most_selected (`numeric`)\cr fitted biomarker level at most often selected dose.
#' @slot mean_biomarker_fit (`list`)\cr list with average, lower (2.5%) and upper (97.5%) quantiles of
#' mean fitted biomarker level at each dose
#' @aliases DualSimulationsSummary
#' @export
.DualSimulationsSummary <-
  setClass(
    Class = "DualSimulationsSummary",
    slots = c(
      biomarker_fit_at_dose_most_selected = "numeric",
      mean_biomarker_fit = "list"
    ),
    contains = "SimulationsSummary"
  )

# default constructor

#' @rdname DualSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultDualSimulationsSummary()` function.
#' @export
.DefaultDualSimulationsSummary <- function() {
  empty_data <- DataDual(doseGrid = c(1, 3, 5, 10, 15, 20, 25, 30))

  my_model <- DualEndpointRW(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2betaW = 0.01,
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    rw1 = TRUE
  )

  my_next_best <- NextBestDualEndpoint(
    target = c(0.9, 1),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )

  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- maxSize(my_size1, my_size2)

  my_stopping1 <- StoppingTargetBiomarker(
    target = c(0.9, 1),
    prob = 0.5
  )

  my_stopping <- my_stopping1 | StoppingMinPatients(10) | StoppingMissingDose()

  my_increments <- IncrementsRelative(
    intervals = c(0, 20),
    increments = c(1, 0.33)
  )

  my_design <- DualDesign(
    model = my_model,
    data = empty_data,
    nextBest = my_next_best,
    stopping = my_stopping,
    increments = my_increments,
    cohort_size = CohortSizeConst(3),
    startingDose = 3
  )

  beta_mod <- function(dose, e0, eMax, delta1, delta2, scal) {
    maxDens <- (delta1^delta1) *
      (delta2^delta2) /
      ((delta1 + delta2)^(delta1 + delta2))
    dose <- dose / scal
    e0 + eMax / maxDens * (dose^delta1) * (1 - dose)^delta2
  }

  true_biomarker <- function(dose) {
    beta_mod(
      dose,
      e0 = 0.2,
      eMax = 0.6,
      delta1 = 5,
      delta2 = 5 * 0.5 / 0.5,
      scal = 100
    )
  }

  true_tox <- function(dose) {
    pnorm((dose - 60) / 10)
  }

  x <- simulate(
    object = my_design,
    trueTox = true_tox,
    trueBiomarker = true_biomarker,
    sigma2W = 0.01,
    rho = 0,
    nsim = 1,
    parallel = FALSE,
    seed = 3,
    startingDose = 6,
    mcmcOptions = .DefaultMcmcOptions()
  )
}

# PseudoSimulations ----

## class ----

#' `PseudoSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#' This class captures trial simulations from designs using pseudo model.
#' It has additional slots `fit` and `stop_reasons` compared to the
#' general class [`GeneralSimulations`].
#'
#' @slot fit (`list`)\cr final fit values.
#' @slot final_td_target_during_trial_estimates (`numeric`)\cr final estimates of the `td_target_during_trial`.
#' @slot final_td_target_end_of_trial_estimates (`numeric`)\cr final estimates of the `td_target_end_of_trial`.
#' @slot final_td_target_during_trial_at_dose_grid (`numeric`)
#'        \cr dose levels at dose grid closest below the final `td_target_during_trial` estimates.
#' @slot final_td_target_end_of_trial_at_dose_grid (`numeric`)
#'        \cr dose levels at dose grid closest below the final `td_target_end_of_trial` estimates.
#' @slot final_tdeot_cis (`list`)\cr 95% credibility intervals of the final estimates for `td_target_end_of_trial`.
#' @slot final_tdeot_ratios (`numeric`)\cr ratio of the upper to the lower 95%
#'        credibility intervals for `td_target_end_of_trial`.
#' @slot final_cis (`list`)\cr final 95% credibility intervals for `td_target_end_of_trial` estimates.
#' @slot final_ratios (`numeric`)\cr final ratios of the upper to the lower 95%
#'        credibility interval for `td_target_end_of_trial`.
#' @slot stop_report (`matrix`)\cr outcomes of stopping rules.
#' @slot stop_reasons (`list`)\cr reasons for stopping each simulation run.
#'
#' @aliases PseudoSimulations
#' @export
.PseudoSimulations <-
  setClass(
    Class = "PseudoSimulations",
    slots = c(
      fit = "list",
      final_td_target_during_trial_estimates = "numeric",
      final_td_target_end_of_trial_estimates = "numeric",
      final_td_target_during_trial_at_dose_grid = "numeric",
      final_td_target_end_of_trial_at_dose_grid = "numeric",
      final_tdeot_cis = "list",
      final_tdeot_ratios = "numeric",
      final_cis = "list",
      final_ratios = "numeric",
      stop_report = "matrix",
      stop_reasons = "list"
    ),
    prototype = prototype(
      final_td_target_during_trial_estimates = c(0.1, 0.1),
      final_td_target_end_of_trial_estimates = c(0.1, 0.1),
      final_td_target_during_trial_at_dose_grid = c(0.1, 0.1),
      final_td_target_end_of_trial_at_dose_grid = c(0.1, 0.1),
      final_tdeot_cis = list(c(0.1, 0.2), c(0.1, 0.2)),
      final_tdeot_ratios = c(0.1, 0.1),
      final_cis = list(c(0.1, 0.2), c(0.1, 0.2)),
      final_ratios = c(0.1, 0.1),
      stop_report = matrix(TRUE, nrow = 2),
      stop_reasons = list("A", "A")
    ),
    contains = "GeneralSimulations",
    validity = v_pseudo_simulations
  )

## constructor ----

#' @rdname PseudoSimulations-class
#'
#' @param fit (`list`)\cr see slot definition.
#' @param final_td_target_during_trial_estimates (`numeric`)\cr see slot definition.
#' @param final_td_target_end_of_trial_estimates (`numeric`)\cr see slot definition.
#' @param final_td_target_during_trial_at_dose_grid (`numeric`)\cr see slot definition.
#' @param final_td_target_end_of_trial_at_dose_grid (`numeric`)\cr see slot definition.
#' @param final_tdeot_cis (`list`)\cr see slot definition.
#' @param final_tdeot_ratios (`numeric`)\cr see slot definition.
#' @param final_cis (`list`)\cr see slot definition.
#' @param final_ratios (`numeric`)\cr see slot definition.
#' @param stop_report see [`PseudoSimulations`]
#' @param stop_reasons (`list`)\cr see slot definition.
#' @param \dots additional parameters from [`GeneralSimulations`]
#'
#' @export
PseudoSimulations <- function(
  fit,
  final_td_target_during_trial_estimates,
  final_td_target_end_of_trial_estimates,
  final_td_target_during_trial_at_dose_grid,
  final_td_target_end_of_trial_at_dose_grid,
  final_tdeot_cis,
  final_tdeot_ratios,
  final_cis,
  final_ratios,
  stop_report,
  stop_reasons,
  ...
) {
  start <- GeneralSimulations(...)
  .PseudoSimulations(
    start,
    fit = fit,
    final_td_target_during_trial_estimates = final_td_target_during_trial_estimates,
    final_td_target_end_of_trial_estimates = final_td_target_end_of_trial_estimates,
    final_td_target_during_trial_at_dose_grid = final_td_target_during_trial_at_dose_grid,
    final_td_target_end_of_trial_at_dose_grid = final_td_target_end_of_trial_at_dose_grid,
    final_tdeot_cis = final_tdeot_cis,
    final_tdeot_ratios = final_tdeot_ratios,
    final_cis = final_cis,
    final_ratios = final_ratios,
    stop_report = stop_report,
    stop_reasons = stop_reasons
  )
}

## default constructor ----

#' @rdname PseudoSimulations-class
#' @note Typically, end users will not use the `.DefaultPseudoSimulations()` function.
#' @export
.DefaultPseudoSimulations <- function() {
  stop(
    "Class PseudoSimulations cannot be instantiated directly. Please use one of its subclasses instead."
  )
}

# PseudoDualSimulations ----

## class ----

#' `PseudoDualSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#' This class conducts trial simulations for designs using both the
#' DLE and efficacy responses. It defines final values for
#' efficacy fit and DLE, estimates of Gstar, optimal dose and sigma2.
#'
#' @slot fit_eff (`list`)\cr final values of efficacy fit.
#' @slot final_gstar_estimates (`numeric`)\cr final Gstar estimates.
#' @slot final_gstar_at_dose_grid (`numeric`)\cr final Gstar estimates at dose grid.
#' @slot final_gstar_cis (`list`)\cr list of 95% confidence interval for Gstar estimates.
#' @slot final_gstar_ratios (`numeric`)\cr ratios of confidence intervals for Gstar estimates.
#' @slot final_optimal_dose (`numeric`)\cr final optimal dose.
#' @slot final_optimal_dose_at_dose_grid (`numeric`)\cr final optimal dose at dose grid.
#' @slot sigma2_est (`numeric`)\cr final sigma2 estimates.
#'
#' @aliases PseudoDualSimulations
#' @export
.PseudoDualSimulations <-
  setClass(
    Class = "PseudoDualSimulations",
    slots = c(
      fit_eff = "list",
      final_gstar_estimates = "numeric",
      final_gstar_at_dose_grid = "numeric",
      final_gstar_cis = "list",
      final_gstar_ratios = "numeric",
      final_optimal_dose = "numeric",
      final_optimal_dose_at_dose_grid = "numeric",
      sigma2_est = "numeric"
    ),
    prototype = prototype(
      final_gstar_estimates = c(0.1, 0.1),
      final_gstar_at_dose_grid = c(0.1, 0.1),
      final_gstar_cis = list(c(0.1, 0.2), c(0.1, 0.2)),
      final_gstar_ratios = c(0.01, 0.01),
      final_optimal_dose = c(0.01, 0.01),
      final_optimal_dose_at_dose_grid = c(0.01, 0.01),
      sigma2_est = c(0.001, 0.002)
    ),
    contains = "PseudoSimulations",
    validity = v_pseudo_dual_simulations
  )

## constructor ----

#' @rdname PseudoDualSimulations-class
#'
#' @param fit_eff (`list`)\cr see slot definition.
#' @param final_gstar_estimates (`numeric`)\cr see slot definition.
#' @param final_gstar_at_dose_grid (`numeric`)\cr see slot definition.
#' @param final_gstar_cis (`list`)\cr see slot definition.
#' @param final_gstar_ratios (`numeric`)\cr see slot definition.
#' @param final_optimal_dose (`numeric`)\cr see slot definition.
#' @param final_optimal_dose_at_dose_grid (`numeric`)\cr see slot definition.
#' @param sigma2_est (`numeric`)\cr see slot definition.
#' @param \dots additional parameters from [`PseudoSimulations`]
#' @export
PseudoDualSimulations <- function(
  fit_eff,
  final_gstar_estimates,
  final_gstar_at_dose_grid,
  final_gstar_cis,
  final_gstar_ratios,
  final_optimal_dose,
  final_optimal_dose_at_dose_grid,
  sigma2_est,
  ...
) {
  start <- PseudoSimulations(...)
  .PseudoDualSimulations(
    start,
    fit_eff = fit_eff,
    final_gstar_estimates = final_gstar_estimates,
    final_gstar_at_dose_grid = final_gstar_at_dose_grid,
    final_gstar_cis = final_gstar_cis,
    final_gstar_ratios = final_gstar_ratios,
    final_optimal_dose = final_optimal_dose,
    final_optimal_dose_at_dose_grid = final_optimal_dose_at_dose_grid,
    sigma2_est = sigma2_est
  )
}

## default constructor ----

#' @rdname PseudoDualSimulations-class
#' @note Do not use the `.DefaultPseudoDualSimulations()` function.
#' @export
.DefaultPseudoDualSimulations <- function() {
  stop(
    "Class PseudoDualSimulations cannot be instantiated directly. Please use a subclass."
  )
}

# PseudoDualFlexiSimulations ----

## class ----

#' `PseudoDualFlexiSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#' This class captures the trial simulations design using both the DLE and
#' efficacy responses using [`EffFlexi`] efficacy model.
#' It extends [`PseudoDualSimulations`] by adding the capability to capture the sigma2betaW estimates.
#'
#' @slot sigma2_beta_w_est (`numeric`)\cr the vector of the final posterior mean sigma2betaW estimates
#' @aliases PseudoDualFlexiSimulations
#' @export
.PseudoDualFlexiSimulations <-
  setClass(
    Class = "PseudoDualFlexiSimulations",
    slots = c(sigma2_beta_w_est = "numeric"),
    prototype = prototype(sigma2_beta_w_est = c(0.001, 0.002)),
    contains = "PseudoDualSimulations"
  )

## constructor ----

#' @rdname PseudoDualFlexiSimulations-class
#'
#' @param sigma2_beta_w_est (`numeric`)\cr the vector of the final posterior mean sigma2betaW estimates
#' @param \dots additional parameters from [`PseudoDualSimulations`]
#'
#' @export
PseudoDualFlexiSimulations <- function(sigma2_beta_w_est, ...) {
  start <- PseudoDualSimulations(...)
  .PseudoDualFlexiSimulations(start, sigma2_beta_w_est = sigma2_beta_w_est)
}

## default constructor ----

#' @rdname PseudoDualFlexiSimulations-class
#' @note Typically, end users will not use the `.DefaultPseudoFlexiSimulations()` function.
#' @export
.DefaultPseudoDualFlexiSimulations <- function() {
  stop(
    "Class PseudoFlexiSimulations cannot be instantiated directly. Please use one of its subclasses instead."
  )
}

# nolint start
## -------------------------------------------------------------------------------------------------------
## ================================================================================================

##' Class for the summary of pseudo-models simulations output
##'
##' Note that objects should not be created by users, therefore no
##' initialization function is provided for this class.
##'
##' @slot targetEndOfTrial the target probability of DLE wanted at the end of a trial
##' @slot targetDoseEndOfTrial the dose level corresponds to the target probability
##' of DLE wanted at the end of a trial, TDEOT
##' @slot targetDoseEndOfTrialAtDoseGrid the dose level at dose grid corresponds to the target probability
##' of DLE wanted at the end of a trial
##' @slot targetDuringTrial the target probability of DLE wanted during a trial
##' @slot targetDoseDuringTrial the dose level corresponds to the target probability of DLE
##' wanted during the trial. TDDT
##' @slot targetDoseDuringTrialAtDoseGrid the dose level at dose grid corresponds to the target probability
##' of DLE wanted during a trial
##' @slot TDEOTSummary the six-number table summary, include the lowest, the 25th precentile (lower quartile),
##' the 50th percentile (median), the mean, the 27th percentile and the highest values of the
##' final dose levels obtained corresponds to the target probability of DLE
##' want at the end of a trial across all simulations
##' @slot TDDTSummary the six-number table summary, include the lowest, the 25th precentile (lower quartile),
##' the 50th percentile (median), the mean, the 27th percentile and the highest values of the
##' final dose levels obtained corresponds to the target probability of DLE
##' want during a trial across all simulations
##' @slot FinalDoseRecSummary the six-number table summary, include the lowest, the 25th precentile (lower quartile),
##' the 50th percentile (median), the mean, the 27th percentile and the highest values of the
##' final optimal doses, which is either the TDEOT when only DLE response are incorporated into
##' the escalation procedure or the minimum of the TDEOT and Gstar when DLE and efficacy responses are
##' incorporated, across all simulations
##' @slot ratioTDEOTSummary the six-number summary table of the final ratios of the upper to the lower 95%
##' credibility intervals of the final TDEOTs across all simulations
##' @slot FinalRatioSummary the six-number summary table of the final ratios of the upper to the lower 95%
##' credibility intervals of the final optimal doses across all simulations
##' #@slot doseRec the dose level that will be recommend for subsequent study
##' @slot nsim number of simulations
##' @slot propDLE proportions of DLE in the trials
##' @slot meanToxRisk mean toxicity risks for the patients
##' @slot doseSelected doses selected as MTD (targetDoseEndOfTrial)
##' @slot toxAtDosesSelected true toxicity at doses selected
##' @slot propAtTargetEndOfTrial Proportion of trials selecting at the doseGrid closest below the MTD, the
##' targetDoseEndOfTrial
##' @slot propAtTargetDuringTrial Proportion of trials selecting at the doseGrid closest below the
##' targetDoseDuringTrial
##' @slot doseMostSelected dose most often selected as MTD
##' @slot obsToxRateAtDoseMostSelected observed toxicity rate at dose most often
##' selected
##' @slot nObs number of patients overall
##' @slot nAboveTargetEndOfTrial number of patients treated above targetDoseEndOfTrial
##' @slot nAboveTargetDuringTrial number of patients treated above targetDoseDuringTrial
##' @slot doseGrid the dose grid that has been used
##' @slot fitAtDoseMostSelected fitted toxicity rate at dose most often selected
##' @slot meanFit list with the average, lower (2.5%) and upper (97.5%)
##' quantiles of the mean fitted toxicity at each dose level
##' @slot stop_report matrix of stopping rule outcomes
##'
##' @export
##' @keywords classes
.PseudoSimulationsSummary <-
  setClass(
    Class = "PseudoSimulationsSummary",
    representation(
      targetEndOfTrial = "numeric",
      targetDoseEndOfTrial = "numeric",
      targetDoseEndOfTrialAtDoseGrid = "numeric",
      targetDuringTrial = "numeric",
      targetDoseDuringTrial = "numeric",
      targetDoseDuringTrialAtDoseGrid = "numeric",
      TDEOTSummary = "table",
      TDDTSummary = "table",
      FinalDoseRecSummary = "table",
      ratioTDEOTSummary = "table",
      FinalRatioSummary = "table",
      # doseRec="numeric",
      nsim = "integer",
      propDLE = "numeric",
      meanToxRisk = "numeric",
      doseSelected = "numeric",
      toxAtDosesSelected = "numeric",
      propAtTargetEndOfTrial = "numeric",
      propAtTargetDuringTrial = "numeric",
      doseMostSelected = "numeric",
      obsToxRateAtDoseMostSelected = "numeric",
      nObs = "integer",
      nAboveTargetEndOfTrial = "integer",
      nAboveTargetDuringTrial = "integer",
      doseGrid = "numeric",
      fitAtDoseMostSelected = "numeric",
      meanFit = "list",
      stop_report = "matrix"
    )
  )

## default constructor ----

#' @rdname GeneralSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultPseudoSimulationsSummary()` function.
#' @export
.DefaultPseudoSimulationsSummary <- function() {
  stop(paste0(
    "Class PseudoSimulationsSummary cannot be instantiated directly.  Please use one of its subclasses instead."
  ))
}

## ---------------------------------------------------------------------------------------------
##' Class for the summary of the dual responses simulations using pseudo models
##'
##' It contains all slots from \code{\linkS4class{PseudoSimulationsSummary}} object. In addition to
##' the slots in the parent class \code{\linkS4class{PseudoSimulationsSummary}}, it contains four
##' more slots for the efficacy model fit information.
##'
##' Note that objects should not be created by users, therefore no initialization function
##' is provided for this class.
##'
##' @slot targetGstar the target dose level such that its gain value is at maximum
##' @slot targetGstarAtDoseGrid the dose level at dose Grid closest and below Gstar
##' @slot GstarSummary the six-number table summary (lowest, 25th, 50th (median), 75th percentile, mean
##' and highest value) of the final Gstar values obtained across all simulations
##' @slot ratioGstarSummary the six-number summary table of the ratios of the upper to the lower 95%
##' credibility intervals of the final Gstar across all simulations
##' @slot EffFitAtDoseMostSelected fitted expected mean efficacy value at dose most often
##' selected
##' @slot meanEffFit list with mean, lower (2.5%) and upper (97.5%) quantiles of the fitted expected
##' efficacy value at each dose level.
##'
##' @export
##' @keywords class
.PseudoDualSimulationsSummary <-
  setClass(
    Class = "PseudoDualSimulationsSummary",
    contains = "PseudoSimulationsSummary",
    representation = representation(
      targetGstar = "numeric",
      targetGstarAtDoseGrid = "numeric",
      GstarSummary = "table",
      ratioGstarSummary = "table",
      EffFitAtDoseMostSelected = "numeric",
      meanEffFit = "list"
    )
  )

## default constructor ----

#' @rdname PseudoDualSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultPseudoDualSimulationsSummary()` function.
#' @export
.DefaultPseudoDualSimulationsSummary <- function() {
  stop(paste0(
    "Class PseudoDualSimulationsSummary cannot be instantiated directly.  Please use one of its subclasses instead."
  ))
}

## ---------------------------------------------------------------------------------------------

##' Class for the simulations output from DA based designs
##'
##' This class captures the trial simulations from DA based
##' designs. In comparison to the parent class \code{\linkS4class{Simulations}},
##' it contains additional slots to capture the time to DLT fits, additional
##' parameters and the trial duration.
##'
##' @slot trialduration the vector of trial duration values for all simulations.
##'
##' @export
##' @keywords classes
.DASimulations <-
  setClass(
    Class = "DASimulations",
    representation(trialduration = "numeric"),
    prototype(trialduration = rep(0, 2)),
    contains = "Simulations",
    validity = v_da_simulations
  )
validObject(.DASimulations())


##' Initialization function for `DASimulations`
##'
##' @param trialduration see \code{\linkS4class{DASimulations}}
##' @param \dots additional parameters from \code{\link{Simulations}}
##' @return the \code{\linkS4class{DASimulations}} object
##'
##' @export
##' @keywords methods
DASimulations <- function(trialduration, ...) {
  start <- Simulations(...)
  .DASimulations(start, trialduration = trialduration)
}


## default constructor ----

#' @rdname DASimulations-class
#' @note Typically, end users will not use the `.DASimulations()` function.  This
#' function has a noticeable execution time.
#' @export
.DefaultDASimulations <- function() {
  design <- .DefaultDADesign()
  myTruth <- probFunction(design@model, alpha0 = 2, alpha1 = 3)
  exp_cond.cdf <- function(x, onset = 15) {
    a <- stats::pexp(28, 1 / onset, lower.tail = FALSE)
    1 - (stats::pexp(x, 1 / onset, lower.tail = FALSE) - a) / (1 - a)
  }

  simulate(
    design,
    args = NULL,
    truthTox = myTruth,
    truthSurv = exp_cond.cdf,
    trueTmax = 80,
    nsim = 2,
    seed = 819,
    mcmcOptions = .DefaultMcmcOptions(),
    firstSeparate = TRUE,
    deescalate = FALSE,
    parallel = FALSE
  )
}
# nolint end

# tidy

## tidy-Simulations ----

#' @rdname tidy
#' @aliases tidy-Simulations
#' @example examples/Simulations-method-tidy.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "Simulations"),
  definition = function(x, ...) {
    slot_names <- slotNames(x)
    rv <- list()
    for (nm in slot_names) {
      if (!is.function(slot(x, nm))) {
        if (nm %in% c("stop_reasons", "additional_stats")) {} else {
          rv[[nm]] <- h_tidy_slot(x, nm)
        }
      }
    }
    # Column bind of all list elements have the same number of rows
    if (length(rv) > 1 & length(unique(sapply(rv, nrow))) == 1) {
      rv <- rv %>% dplyr::bind_cols()
    }
    rv %>% h_tidy_class(x)
  }
)

# Integration with knitr ----
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' We provide additional utility functions to allow human-friendly rendition of
#' crmPack objects in Markdown and Quarto files
#'
#' @return a character string that represents the object in markdown.
#' @name knit_print
NULL

# CohortSize ----

#' Render a `CohortSizeConst` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @param x (`CohortSize`)\cr The object to knit_print.
#' @param asis (`flag`)\cr Should the return value be wrapped in a call to `knitr::asis_output`?
#' @param label (`character`)\cr The word used to label the participants.  See Usage Notes below.
#' @param ... Not used at present
#'
#' @section Usage Notes:
#' `label` describes the trial's participants.
#'
#' It should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a `cohort_size` of 1 and the second describes all other
#' `cohort_size`s.  If of length 1, the character `s` is appended to the value
#' when `cohort_size` is not 1.
#' @return The markdown representation of the object, as a character string
#' @seealso [`knit_print`] for more details.
#'
#' @export
#' @method knit_print CohortSizeConst
#' @rdname knit_print
knit_print.CohortSizeConst <- function(
  x,
  ...,
  asis = TRUE,
  label = c("participant", "participants")
) {
  assert_flag(asis)

  label <- h_prepare_labels(label)
  rv <- paste0(
    "A constant size of ",
    x@size,
    " ",
    label[ifelse(x@size == 1, 1, 2)],
    ".\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeRange` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @param ... passed to `knitr::kable`
#' @inherit knit_print.CohortSizeConst return
#' @section Usage Notes:
#' The default value of `col.names` is `c("Lower", "Upper", "Cohort size")` and
#' that of `caption` is `"Defined by the dose to be used in the next cohort"`.
#' These values can be overridden by passing `col.names` and `caption` in the
#' function call.
#' @export
#' @method knit_print CohortSizeRange
#' @rdname knit_print
knit_print.CohortSizeRange <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Lower", "Upper", "Cohort size")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- "Defined by the dose to be used in the next cohort"
  }
  x <- tidy(x)
  param[["x"]] <- x
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    c("Dose" = 2, " " = 1)
  )
  rv <- paste0(rv, "\n\n")

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeDLT` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... Passed to [knitr::kable()].
#'
#' @section Usage Notes:
#' The by default, the columns are labelled `Lower`, `Upper` and `Cohort size`.
#'  The table's caption is `Defined by the number of <tox_label[2]> so far observed`.
#'  These values can be overridden by passing `col.names` and `caption` in the
#'  function call.
#'
#' @export
#' @method knit_print CohortSizeDLT
#' @rdname knit_print
knit_print.CohortSizeDLT <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  assert_flag(asis)
  param <- list(...)
  tox_label <- h_prepare_labels(tox_label)

  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Lower", "Upper", "Cohort size")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- paste0(
      "Defined by the number of ",
      tox_label[2],
      " so far observed"
    )
  }
  param[["x"]] <- tidy(x)
  headers <- c(2, 1)
  names(headers) <- c(paste0("No of ", tox_label[2]), " ")
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    headers
  )
  rv <- paste0(rv, "\n\n")

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeParts` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @inheritSection knit_print.CohortSizeConst Usage Notes
#'
#' @export
#' @method knit_print CohortSizeParts
#' @rdname knit_print
knit_print.CohortSizeParts <- function(
  x,
  ...,
  asis = TRUE,
  label = c("participant", "participants")
) {
  assert_flag(asis)

  label <- h_prepare_labels(label)
  rv <- paste0(
    "A size of ",
    x@cohort_sizes[1],
    " ",
    label[ifelse(x@cohort_sizes[1] == 1, 1, 2)],
    " in the first part and ",
    x@cohort_sizes[2],
    " ",
    label[ifelse(x@cohort_sizes[2] == 1, 1, 2)],
    " in the second.\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeMax` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` methods of the constituent
#' rules
#'
#' @export
#' @method knit_print CohortSizeMax
#' @rdname knit_print
knit_print.CohortSizeMax <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  params <- list(...)
  params[["asis"]] <- asis
  rv <- paste0(
    "The maximum of the cohort sizes defined in the following rules:",
    paste0(
      lapply(
        x@cohort_sizes,
        function(x) {
          knit_print(x, ..., asis = asis)
        }
      ),
      collapse = "\n"
    ),
    "\n\n",
    paste = "\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeMin` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` methods of the constituent
#' rules
#'
#' @export
#' @method knit_print CohortSizeMin
#' @rdname knit_print
knit_print.CohortSizeMin <- function(x, ..., asis = TRUE) {
  assert_flag(asis)
  rv <- paste0(
    "The minimum of the cohort sizes defined in the following rules:",
    paste0(
      lapply(
        x@cohort_sizes,
        function(x, ...) {
          knit_print(x, asis = asis, ...)
        }
      ),
      collapse = "\n"
    ),
    "\n\n",
    sep = "\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeOrdinal` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` method of the standard rule
#'
#' @export
#' @method knit_print CohortSizeOrdinal
#' @rdname knit_print
knit_print.CohortSizeOrdinal <- function(
  x,
  ...,
  tox_label = "toxicity",
  asis = TRUE
) {
  assert_flag(asis)
  tox_label <- h_prepare_labels(tox_label)

  rv <- paste0(
    "Based on a ",
    tox_label[1],
    " grade of ",
    x@grade,
    ": ",
    paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n"),
    "\n\n",
    sep = "\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# GeneralSimulations ----

#' Internal Helper Functions for Validation of [`GeneralSimulations`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`GeneralSimulations`] or inherited classes and therefore not exported.
#'
#' @name v_general_simulations
#' @param object (`GeneralSimulations`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_general_simulations validates that the [`GeneralSimulations`] object
#'   contains valid `data` object and valid `dose` simulations.

v_general_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    all(sapply(object@data, is, "Data")),
    "all data elements must be Data objects"
  )
  v$check(
    identical(length(object@doses), nSims),
    "doses must have same length as the data list"
  )

  v$result()
}

#' @describeIn v_general_simulations validates that the [`Simulations`] object
#'   contains valid object `fit`, `stop_reasons`, `stop_report`, and
#'   `additional_stats` compared to the general class [`GeneralSimulations`].
#'
v_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    identical(length(object@fit), nSims),
    "fit must have same length as data"
  )
  v$check(
    identical(length(object@stop_reasons), nSims),
    "stop_reasons must have same length as data"
  )

  v$check(
    checkmate::test_matrix(
      object@stop_report,
      mode = "logical",
      nrows = nSims,
      min.cols = 1,
      any.missing = FALSE
    ),
    "stop_report must be a matrix of mode logical in which the number of rows
    equals the number of simulations and which must not contain any missing values"
  )

  v$result()
}

#' @describeIn v_general_simulations validates that the [`DualSimulations`] object and
#' capture the dose-biomarker `fits`, and the `sigma2W` and `rho` estimates.
#'
v_dual_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    identical(length(object@fit_biomarker), nSims),
    "fit_biomarker list has to have same length as data"
  )
  v$check(
    identical(length(object@rho_est), nSims),
    "rho_est vector has to have same length as data"
  )
  v$check(
    identical(length(object@sigma2w_est), nSims),
    "sigma2w_est has to have same length as data"
  )

  v$result()
}

# PseudoSimulations ----

#' Internal Helper Functions for Validation of [`PseudoSimulations`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`PseudoSimulations`] or inherited classes and therefore not exported.
#'
#' @name v_pseudo_simulations
#' @param object (`PseudoSimulations`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_pseudo_simulations validates that the [`PseudoSimulations`] object
#'   contains valid `fit`, `FinalTDtargetEndOfTrialEstimates` ,
#'   `FinalTDtargetDuringTrialAtDoseGrid`,`FinalTDtargetEndOfTrialAtDoseGrid` ,
#'   `FinalTDEOTCIs`, `FinalTDEOTRatios`, `FinalCIs`, `FinalRatios`,
#'     object and valid `stopReasons` simulations.

v_pseudo_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)
  v$check(
    identical(length(object@stop_reasons), nSims),
    "stopReasons must have same length as data"
  )

  v$result()
}

#' @describeIn v_pseudo_simulations validates that the [`PseudoDualSimulations`] object
#'   contains valid `fit_eff`, `final_gstar_estimates` , `final_gstar_at_dose_grid`,
#'    `final_gstar_cis` , `final_gstar_ratios`, `final_optimal_dose`, `final_optimal_dose_at_dose_grid`
#'     object and valid `sigma2_est` simulations.

v_pseudo_dual_simulations <- function(object) {
  v <- Validate()
  nSims <- length(object@data)
  v$check(
    identical(length(object@sigma2_est), nSims),
    "sigma2_est has to have same length as data"
  )
  v$result()
}

#' @describeIn v_pseudo_simulations validates that the [`PseudoDualFlexiSimulations`]
#' object contains valid `sigma2_beta_w_est` vector of the final posterior mean
#' sigma2betaW estimates.`FinalGstarEstimates` , `FinalGstarAtDoseGrid`,
#'
v_pseudo_dual_flex_simulations <- function(object) {
  v <- Validate()
  nSims <- length(object@data)
  v$check(
    identical(length(object@sigma2_beta_w_est), nSims),
    "sigma2_beta_w_est has to have same length as data"
  )
  v$result()
}

#' @describeIn v_general_simulations validates that the [`DASimulations`] object
#'   contains valid `trialduration` the vector of trial duration values for all
#'   simulations.

v_da_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    identical(length(object@trialduration), nSims),
    "trialduration vector has to have same length as data"
  )

  v$result()
}

#' @include helpers.R
NULL

#' Appending a Dummy Number for Selected Slots in Data
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A helper function that appends a dummy value to a given slots in [`GeneralData`]
#' class object, if and only if the total number of observations (as indicated
#' by `object@nObs`) equals to `1`. Otherwise, the `object` is not changed.
#'
#' @note The main motivation behind this function is related to the `JAGS`.
#'   If there is only one observation, the data is not passed correctly to
#'   `JAGS`, i.e. e.g. `x` and `y` are treated like scalars in the data file.
#'   Therefore it is necessary to add dummy values to the vectors in this case
#'   As we don't change the number of observations (`nObs`), this addition of
#'   zeros doesn't affect the results of `JAGS` computations.
#'
#' @param object (`GeneralData`)\cr object into which dummy values will be added.
#' @param where (`character`)\cr names of slots in `object` to which a `dummy`
#'   number will be appended.
#' @param dummy (`number`)\cr a dummy number that will be appended to selected
#'   slots in `object`. Default to `0`.
#'
#' @return A [`GeneralData`] object with slots updated with dummy number.
#'
#' @export
#' @example examples/helpers-jags_add_dummy.R
#'
h_jags_add_dummy <- function(object, where, dummy = 0) {
  assert_class(object, "GeneralData")
  assert_character(where)
  assert_subset(where, slotNames(object))
  assert_number(dummy)

  if (object@nObs == 1L) {
    for (i in where) {
      # Add dummy value and preserve the class.
      slot(object, i) <- as(c(slot(object, i), dummy), class(slot(object, i)))
    }
  }
  object
}

#' Joining `JAGS` Models
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This helper function joins two JAGS models in the way that the body of the
#' second model is appended to the body of the first model (in this order).
#' After that, the first, body-extended model is returned. The arguments of
#' `model1`, `model2` model functions (if any) are not combined in any way.
#'
#' @note `model1` and `model2` functions must have a multi-expression
#'   body, i.e. braced expression(s). Environments or any attributes of the
#'   function bodies are not preserved in any way after joining.
#'
#' @param model1 (`function`)\cr the first model to join.
#' @param model2 (`function`)\cr the second model to join.
#'
#' @return joined models.
#'
#' @export
#'
h_jags_join_models <- function(model1, model2) {
  assert_function(model1)
  assert_function(model2)
  assert_class(body(model1), "{")
  assert_class(body(model2), "{")

  # This workaround is needed to avoid bugs related to covr-injected code.
  if (h_covr_active()) {
    body(model2) <- h_covr_detrace(body(model2))
  }

  body2 <- as.list(body(model2))
  if (length(body2) >= 2) {
    body1 <- as.list(body(model1))
    body(model1) <- as.call(c(body1, body2[-1]))
  }
  model1
}


#' Setting Initial Values for `JAGS` Model Parameters
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that prepares an object for `inits` argument of
#'   [rjags::jags.model()], which is invoked by [mcmc()] method. The `inits`
#'   argument specifies initial values for model parameters.
#'
#' @param model (`GeneralModel`)\cr an input model.
#' @param data (`GeneralData`)\cr an input data.
#'
#' @return A `list` of starting values for parameters required to be initialized
#'   in the MCMC `JAGS `sampler.
#'
#' @export
#' @example examples/helpers-jags_get_model_inits.R
#'
h_jags_get_model_inits <- function(model, data) {
  assert_class(model, "GeneralModel")
  assert_class(data, "GeneralData")

  inits <- do.call(model@init, h_slots(data, formalArgs(model@init)))
  assert_list(inits)
  inits[sapply(inits, length) > 0L]
}

#' Getting Data for `JAGS`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that prepares an object for `data` argument of
#'   [rjags::jags.model()], which is invoked by [mcmc()] method.
#'
#' @param model (`GeneralModel`)\cr an input model.
#' @param data (`GeneralData`)\cr an input data.
#' @param from_prior (`flag`)\cr sample from the prior only? In this case
#'   data will not be appended to the output, i.e. only the variables required
#'   by the `model@priormodel` model will be returned in data.
#'
#' @export
#' @example examples/helpers-jags_get_data.R
#'
h_jags_get_data <- function(model, data, from_prior) {
  assert_class(model, "GeneralModel")
  assert_class(data, "GeneralData")
  assert_flag(from_prior)

  # 1) Extract variables from `data` as required by `modelspecs`.
  ms_args_names <- formalArgs(model@modelspecs)
  ms_args <- if ("from_prior" %in% ms_args_names) {
    c(
      h_slots(data, setdiff(ms_args_names, "from_prior")),
      list(from_prior = from_prior)
    )
  } else {
    h_slots(data, ms_args_names)
  }
  modelspecs <- do.call(model@modelspecs, ms_args)
  assert_list(modelspecs)

  # 2) Extract variables from `data` as required by `datanames`.
  datanames <- if (from_prior) {
    model@datanames_prior
  } else {
    union(model@datanames, model@datanames_prior)
  }

  # Add dummy to ensure that e.g. `x` and `y` in `data` won't be treated as
  # scalars by `JAGS` if `data@nObs == 1`, which leads to failures.
  add_where <- setdiff(
    datanames,
    c("nObs", "nGrid", "nObsshare", "yshare", "xshare", "Tmax")
  )
  data <- h_jags_add_dummy(data, where = add_where)

  data_model <- h_slots(data, datanames)
  c(data_model, modelspecs)
}

#' Writing JAGS Model to a File
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function converts a R function with JAGS model into a text and then
#' writes it into a given file. During the "model into text" conversion, the
#' format of numbers of which absolute value is less than `0.001` or greater
#' than `10000` is changed. These numbers will be converted into scientific
#' format with specified number of significant digits using [formatC()]
#' function.
#'
#' @note JAGS syntax allows truncation specification like `dnorm(...) I(...)`,
#'   which is illegal in R. To overcome this incompatibility, use dummy operator
#'   `\%_\%` before `I(...)`, i.e. `dnorm(...) \%_\% I(...)` in the model's
#'   code. This dummy operator `\%_\%` will be removed just before saving the
#'   JAGS code into a file.
#'   Due to technical issues related to conversion of numbers to scientific
#'   format, it is required that the body of a model function does not contain
#'   `TEMP_NUM_PREF_` or `_TEMP_NUM_SUF` character constants in its body.
#'
#' @param model (`function`)\cr function containing the JAGS model.
#' @param file (`string` or `NULL`)\cr the name of the file (including the
#'   optional path) where the model will be saved. If `NULL`, the file will be
#'   created in a `R_crmPack` folder placed under temporary directory indicated
#'   by [tempdir()] function.
#' @param digits (`count`)\cr a desired number of significant digits for
#'   for numbers used in JAGS input, see [formatC()].
#' @return The name of the file where the model was saved.
#'
#' @export
#' @example examples/helpers-jags_write_model.R
#'
h_jags_write_model <- function(model, file = NULL, digits = 5) {
  assert_function(model)
  assert_count(digits)

  # This workaround is needed to avoid bugs related to covr-injected code.
  if (h_covr_active()) {
    body(model) <- h_covr_detrace(body(model))
  }

  if (!is.null(file)) {
    assert_path_for_output(file)
  } else {
    dir <- file.path(tempdir(), "R_crmPack")
    # Don't warn, as the temp dir often exists (which is OK).
    dir.create(dir, showWarnings = FALSE)
    file <- tempfile(
      pattern = "jags_model_fun",
      tmpdir = dir,
      fileext = ".txt"
    )
  }

  # Replace scientific notation.
  model_sci_replaced <- h_rapply(
    x = body(model),
    fun = h_format_number,
    classes = c("integer", "numeric"),
    digits = digits,
    prefix = "TEMP_NUM_PREF_",
    suffix = "_TEMP_NUM_SUF"
  )
  # Transform `model` body into character vector.
  model_text <- deparse(model_sci_replaced, control = NULL)
  model_text <- gsub("\"TEMP_NUM_PREF_|_TEMP_NUM_SUF\"", "", model_text)
  model_text <- gsub("%_% ", "", model_text)
  model_text <- c("model", model_text)

  log_trace("Writting JAGS model function into: %s", file)
  writeLines(model_text, con = file)
  file
}

#' Extracting Samples from `JAGS` `mcarray` Object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that extracts a sample from
#'   [`rjags::mcarray.object`] S3 class object. The [`rjags::mcarray.object`]
#'   object is used by the [rjags::jags.samples()] function to represent MCMC
#'   output from a `JAGS` model.
#'
#' @param x an [`rjags::mcarray.object`] object.
#'
#' @export
#'
h_jags_extract_samples <- function(x) {
  assert_class(x, "mcarray")

  x <- x[,, 1L]
  # In case that there are multiple parameters in a node.
  if (is.matrix(x)) {
    x <- t(x)
  }
  x
}

#' Convert a Samples Object from an ordinal Model to the Equivalent Samples Object
#' from a Binary Model
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that converts a [`Samples`] object from the fit of an
#' ordinal CRM model to that which would have been obtained from fitting a binary
#' CRM model for toxicities of a specified grade to the same observed data.
#'
#' @param obj (`Samples`)\cr the `Samples` object to covert
#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
#' is required.
#' @return A [`Samples`] object.
#'
#' @export
h_convert_ordinal_samples <- function(obj, grade) {
  # Validate
  assert_integer(grade, len = 1, lower = 1)
  assert_class(obj, "Samples")
  assert_subset(c(paste0("alpha", 1:grade), "beta"), names(obj@data))
  # Execute
  d <- list(
    "alpha0" = obj@data[[paste0("alpha", grade)]],
    "alpha1" = obj@data$beta
  )
  Samples(data = d, options = obj@options)
}

#' Update [`DualEndpoint`] class model components with regard to biomarker
#' regression variance.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] model existing components
#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
#' to biomarker regression variance `sigma2W`.
#'
#' @param use_fixed (`flag`)\cr indicates whether a fixed value for the biomarker
#'   regression variance `sigma2W` should be used or not. If `sigma2W` is not
#'   supposed to be a fixed value, a prior distribution from the Inverse-Gamma
#'   distribution will be used. See the details below, under `sigma2W` argument.
#' @param sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
#'   Inverse-Gamma distribution parameters, i.e. vector with two elements named
#'   `a` and `b`.
#' @param comp (`list`)\cr a named list with model components that will be updated.
#'   The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
#'   definitions of the components, see [`GeneralModel`] class.
#'   The `modelspecs` and `init` components on `comp` list are specified up to
#'   the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
#'   functions. These bodies are simply a lists itself.
#'
#' @return `list` with updated model components.
#'
#' @export
h_model_dual_endpoint_sigma2W <- function(
  use_fixed, # nolintr
  sigma2W,
  comp
) {
  if (use_fixed) {
    assert_number(sigma2W, lower = 0 + .Machine$double.xmin, finite = TRUE)
    comp$modelspecs$precW <- 1 / sigma2W
  } else {
    assert_true(h_test_named_numeric(sigma2W, permutation.of = c("a", "b")))
    comp$priormodel <- h_jags_join_models(
      comp$priormodel,
      function() {
        precW ~ dgamma(precWa, precWb)
      }
    )
    comp$modelspecs$precWa <- sigma2W[["a"]]
    comp$modelspecs$precWb <- sigma2W[["b"]]
    comp$init$precW <- 1
    comp$sample <- c(comp$sample, "precW")
  }
  comp
}

#' Update [`DualEndpoint`] class model components with regard to DLT and biomarker
#' correlation.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] model existing components
#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
#' DLT and biomarker correlation `rho`.
#'
#' @param use_fixed (`flag`)\cr indicates whether a fixed value for DLT and
#'   biomarker correlation `rho` should be used or not. If `rho` is not supposed
#'   to be a fixed value, a prior distribution from the scaled Beta family will
#'   be used. See the details below, under `rho` argument.
#' @param rho (`numeric`)\cr DLT and biomarker correlation. It must be either a
#'   fixed value (between `-1` and `1`), or a named vector with two elements,
#'   named `a` and `b` for the Beta prior on the transformation
#'   `kappa = (rho + 1) / 2`, which is in `(0, 1)`. For example, `a = 1, b = 1`
#'   leads to a uniform prior on `rho`.
#' @param comp (`list`)\cr a named list with model components that will be updated.
#'   The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
#'   definitions of the components, see [`GeneralModel`] class.
#'   The `modelspecs` and `init` components on `comp` list are specified up to
#'   the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
#'   functions. These bodies are simply a lists itself.
#'
#' @return A `list` with updated model components.
#'
#' @export
h_model_dual_endpoint_rho <- function(use_fixed, rho, comp) {
  rmin <- .Machine$double.xmin
  if (use_fixed) {
    assert_number(rho, lower = -1 + rmin, upper = 1 - rmin)
    comp$modelspecs$rho <- rho
  } else {
    assert_true(h_test_named_numeric(rho, permutation.of = c("a", "b")))
    comp$priormodel <- h_jags_join_models(
      comp$priormodel,
      function() {
        kappa ~ dbeta(rhoa, rhob)
        rho <- 2 * kappa - 1
      }
    )
    comp$modelspecs$rhoa <- rho[["a"]]
    comp$modelspecs$rhob <- rho[["b"]]
    comp$init$kappa <- 0.5
    comp$sample <- c(comp$sample, "rho")
  }
  comp
}

#' Update certain components of [`DualEndpoint`] model with regard to prior variance
#' factor of the random walk.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] object and updates
#' `priormodel`, `modelspecs`, `init`, `sample` slots according to the random walk
#' variance.
#'
#' @param use_fixed (`flag`)\cr indicates whether a fixed value for
#'   `sigma2betaW` should be used or not. If `sigma2betaW` is not supposed
#'   to be a fixed value, a prior distribution from the Inverse-Gamma distribution
#'   will be used. See the details below, under `sigma2betaW` argument.
#' @param sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
#'   prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
#'   parameters, i.e. vector with two elements named `a` and `b`.
#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
#'
#' @return A [`DualEndpoint`] model with updated `priormodel`, `modelspecs`,
#'   `init`, `sample` slots.
#'
#' @seealso [`DualEndpointRW`].
#' @export
h_model_dual_endpoint_sigma2betaW <- function(
  use_fixed, # nolintr
  sigma2betaW,
  de
) {
  modelspecs <- de@modelspecs
  init <- de@init

  if (use_fixed) {
    assert_number(sigma2betaW, lower = 0 + .Machine$double.xmin, finite = TRUE)
    ms <- list(precBetaW = 1 / sigma2betaW)
  } else {
    assert_true(h_test_named_numeric(sigma2betaW, permutation.of = c("a", "b")))
    # gamma prior for random walk precision.
    de@priormodel <- h_jags_join_models(
      de@priormodel,
      function() {
        precBetaW ~ dgamma(precBetaWa, precBetaWb)
      }
    )
    ms <- list(precBetaWa = sigma2betaW[["a"]], precBetaWb = sigma2betaW[["b"]])
    de@init <- function(y) {
      c(init(y), list(precBetaW = 1))
    }
    de@sample <- c(de@sample, "precBetaW")
  }
  de@modelspecs <- function(from_prior) {
    c(modelspecs(from_prior), ms)
  }
  de
}

#' Update certain components of [`DualEndpoint`] model with regard to parameters
#' of the function that models dose-biomarker relationship defined in the
#' [`DualEndpointBeta`] class.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] object and updates
#' `use_fixed`, `priormodel`, `modelspecs`, `init`, `sample` slots with regard
#' to a given parameter of the dose-biomarker relationship \eqn{f(x)} defined in
#' the [`DualEndpointBeta`] class. This update solely depends on whether a given
#' parameter's value `param` is a fixed-valued scalar or two-elements numeric
#' vector. In the later case, it is assumed that `param` represents two
#' parameters of a probability distribution that will be used in `priormodel`
#' function to generate values for the `param_name` parameter of \eqn{f(x)}.
#' See the help page for [`DualEndpointBeta`] class for more details.
#'
#' @param param (`numeric`)\cr the value of a given `param_name` parameter of
#'   the dose-biomarker relationship function \eqn{f(x)}. Either a fixed-valued
#'   scalar or vector with two elements that are the parameters of a probability
#'   distribution that will be used in `priormodel` function to generate values
#'   for the `param_name` parameter of \eqn{f(x)}.
#' @param param_name (`string`)\cr the name of the parameter of \eqn{f(x)},
#'   whose value depends on `param`.
#' @param param_suffix (`character`)\cr the two suffixes to be appended to
#'   the elements of `param_name` and then used when updating `modelspecs`.
#'   The value of this argument is ignored when `param` is a scalar.
#' @param priormodel (`function` or `NULL`)\cr a function representing the
#'   `JAGS` prior specification that will be appended to existing
#'   `de@priormodel` specification if `param` is not a scalar. Otherwise,
#'   `de@priormodel` remains unchanged.
#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
#'
#' @return A [`DualEndpoint`] model with updated `use_fixed`, `priormodel`,
#'   `modelspecs`, `init`, `sample` slots.
#'
#' @export
h_model_dual_endpoint_beta <- function(
  param,
  param_name,
  param_suffix = c("_low", "_high"),
  priormodel = NULL,
  de
) {
  assert_numeric(param, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_string(param_name)
  assert_class(de, "DualEndpoint")

  use_fixed <- setNames(test_number(param), param_name)
  modelspecs <- de@modelspecs
  init <- de@init

  if (use_fixed) {
    ms <- setNames(list(param), param_name)
  } else {
    assert_character(param_suffix, len = 2, unique = TRUE, any.missing = FALSE)
    assert_function(priormodel)
    param_name2 <- paste0(param_name, param_suffix)

    de@priormodel <- h_jags_join_models(
      de@priormodel,
      priormodel
    )
    ms <- setNames(list(param[1], param[2]), param_name2)
    de@init <- function(y) {
      c(init(y), setNames(list(mean(param)), param_name))
    }
    de@sample <- c(de@sample, param_name)
  }
  de@modelspecs <- function(from_prior) {
    c(modelspecs(from_prior), ms)
  }
  de@use_fixed <- c(de@use_fixed, use_fixed)
  de
}

#' Convert an ordinal CRM model to the Equivalent Binary CRM Model for a Specific
#' Grade
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that takes a [`LogisticLogNormalOrdinal`] and an
#' integer grade and converts them to the equivalent `LogisticLogNormal` model.
#'
#' @param x (`LogisticLogNormalOrdinal`)\cr the `LogisticLogNormalOrdinal`
#'   model to covert
#' @param grade (`integer`)\cr the toxicity grade for which the equivalent model
#' is required.
#' @return A [`LogisticLogNormal`] model.
#'
#' @export
h_convert_ordinal_model <- function(x, grade) {
  # Validate
  assert_integer(grade, len = 1, lower = 1)
  assert_class(x, "LogisticLogNormalOrdinal")
  # Execute
  LogisticLogNormal(
    mean = x@params@mean[-grade],
    cov = x@params@cov[-grade, -grade],
    ref_dose = x@ref_dose
  )
}

#' Apply a Function to Subsets of Data Frame.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' `dapply` splits the data `df` into the subsets defined by `f`,
#' and applies function `FUN` to each of the subset.
#' All the results are row-binded and returned as `data.frame` object.
#'
#' @param df (`data frame`)\cr data set to be divided into groups.
#' @param f (`factor` or `formula` or `list`)\cr a factor in the sense that
#'   `as.factor(f)` defines the grouping, or a `list` of such factors in which
#'   case their interaction is used for the grouping. `f` can also be a formula
#'   of the form `~ g1 + ... + gk` to split by the interaction of the variables
#'   `g1, ..., gk`. This parameter is passed directly into [split()] function.
#' @param FUN (`function`)\cr the function to be applied to each subset of `df`
#'   defined by `f`.
#' @param ... parameters passed to [lapply()], which is used when applying a
#'   function `FUN` over groups defined by `f`.
#'
#' @return The [`data.frame`] object with results from `FUN`.
#'
#' @export
#' @example examples/utils-dapply.R
#'
dapply <- function(df, f, FUN, ...) {
  assert_data_frame(df)

  list_df <- split(df, f = f)
  list_df <- lapply(list_df, FUN, ...)
  df2 <- do.call(rbind, list_df)
  rownames(df2) <- NULL
  df2
}

# Design ----

#' Internal Helper Functions for Validation of [`RuleDesign`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`RuleDesign`] or inherited classes and therefore not exported.
#'
#' @name v_design
#' @param object (`RuleDesign`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_design validates that the [`RuleDesign`] object
#'   contains valid `startingDose`.
v_rule_design <- function(object) {
  v <- Validate()
  v$check(
    test_number(object@startingDose, finite = TRUE),
    "startingDose must be a number"
  )
  v$check(
    test_subset(
      object@startingDose,
      choices = object@data@doseGrid,
      empty.ok = FALSE
    ),
    "startingDose must be included in data@doseGrid"
  )
  v$result()
}

#' Internal Helper Functions for Validation of [`RuleDesignOrdinal`] Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' These functions are only used internally to validate the format of an input
#' [`RuleDesignOrdinal`] or inherited classes and therefore not exported.
#'
#' @name v_design
#' @param object (`RuleDesignOrdinal`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_design validates that the [`RuleDesignOrdinal`] object
#'   contains valid `starting_dose`.
v_rule_design_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_number(object@starting_dose, finite = TRUE),
    "starting_dose must be a number"
  )
  v$check(
    test_subset(
      object@starting_dose,
      choices = object@data@doseGrid,
      empty.ok = FALSE
    ),
    "starting_dose must be included in data@doseGrid"
  )
  v$result()
}


#' @describeIn v_design validates that the [`DesignGrouped`] object
#'   contains valid flags.
v_design_grouped <- function(object) {
  v <- Validate()
  v$check(
    test_flag(object@first_cohort_mono_only),
    "first_cohort_mono_only must be a flag"
  )
  v$check(
    test_flag(object@same_dose_for_all),
    "same_dose_for_all must be a flag"
  )
  v$check(
    test_flag(object@same_dose_for_all),
    "same_dose_for_start must be a flag"
  )
  v$result()
}

#' Internal Helper Functions for Validation of [`GeneralData`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`GeneralData`] or inherited classes and therefore not exported.
#'
#' @name v_data_objects
#' @param object (`GeneralData`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_data_objects validates that the [`GeneralData`]
#'   object contains unique `ID`, non-negative `cohort` indices and
#'   `ID` and `cohort` vectors are of the same length `nObs`.
v_general_data <- function(object) {
  v <- Validate()
  # In if clause so that below test_* won't fail.
  if (!test_int(object@nObs)) {
    return("nObs must be of type integer of length 1")
  }
  v$check(
    test_integer(
      object@ID,
      len = object@nObs,
      any.missing = FALSE,
      unique = TRUE,
      null.ok = TRUE
    ),
    "ID must be of type integer and length nObs and unique"
  )
  v$check(
    test_integer(
      object@cohort,
      lower = 0L,
      len = object@nObs,
      any.missing = FALSE,
      sorted = TRUE
    ),
    "cohort must be of type integer and length nObs and contain non-negative, sorted values"
  )
  v$result()
}

#' @describeIn v_data_objects helper function which verifies whether
#'   the `dose` values are unique in each and every different `cohort`.
#' @param dose (`numeric`)\cr dose values.
#' @param cohort (`integer`)\cr cohort indices parallel to `doses`.
#' @return `TRUE` if `dose` is unique per `cohort`, otherwise `FALSE`.
h_doses_unique_per_cohort <- function(dose, cohort) {
  assert_numeric(dose)
  assert_integer(cohort)

  num_doses_per_cohort <- tapply(
    X = dose,
    INDEX = cohort,
    FUN = function(d) length(unique(d))
  )
  all(num_doses_per_cohort == 1L)
}

#' Helper Function performing validation Common to Data and DataOrdinal
#'
#' @rdname h_validate_common_data_slots
#' @param object (`Data` or `DataOrdinal`)\cr the object to be validated
#' @returns a `Validate` object containing the result of the validation
h_validate_common_data_slots <- function(object) {
  v <- Validate()
  v$check(
    test_double(object@x, len = object@nObs, any.missing = FALSE),
    "Doses vector x must be of type double and length nObs"
  )
  v$check(
    test_double(
      object@doseGrid,
      len = object@nGrid,
      any.missing = FALSE,
      unique = TRUE,
      sorted = TRUE
    ),
    "doseGrid must be of type double and length nGrid and contain unique, sorted values"
  )
  v$check(
    test_int(object@nGrid),
    "Number of dose grid values nGrid must be scalar integer"
  )
  v$check(
    test_integer(object@xLevel, len = object@nObs, any.missing = FALSE),
    "Levels xLevel for the doses the patients have been given must be of type integer and length nObs"
  )
  v$check(
    test_flag(object@placebo),
    "The placebo flag must be scalar logical"
  )
  v$check(
    test_subset(object@x, object@doseGrid),
    "Dose values in x must be from doseGrid"
  )
  v$check(
    h_all_equivalent(object@x, object@doseGrid[object@xLevel]),
    "x must be equivalent to doseGrid[xLevel] (up to numerical tolerance)"
  )
  if (object@placebo) {
    is_placebo <- object@x == object@doseGrid[1]
    v$check(
      test_set_equal(object@cohort, object@cohort[!is_placebo]),
      "A cohort with only placebo is not allowed"
    )
    v$check(
      h_doses_unique_per_cohort(
        dose = object@x[!is_placebo],
        cohort = object@cohort[!is_placebo]
      ),
      "There must be only one dose level, other than placebo, per cohort"
    )
  } else {
    v$check(
      h_doses_unique_per_cohort(dose = object@x, cohort = object@cohort),
      "There must be only one dose level per cohort"
    )
  }
  v
}

#' @describeIn v_data_objects validates that the [`Data`] object contains
#'   valid elements with respect to their types, dependency and length.
v_data <- function(object) {
  v <- h_validate_common_data_slots(object)
  v$check(
    test_integer(
      object@y,
      lower = 0,
      upper = 1,
      len = object@nObs,
      any.missing = FALSE
    ),
    "DLT vector y must be nObs long and contain 0 or 1 integers only"
  )

  v$result()
}

#' @describeIn v_data_objects validates that the [`DataDual`] object
#' contains valid biomarker vector with respect to its type and the length.
v_data_dual <- function(object) {
  v <- Validate()
  v$check(
    test_double(object@w, len = object@nObs, any.missing = FALSE),
    "Biomarker vector w must be of type double and length nObs"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataParts`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_parts <- function(object) {
  v <- Validate()
  v$check(
    test_integer(
      object@part,
      lower = 1,
      upper = 2,
      len = object@nObs,
      any.missing = FALSE
    ),
    "vector part must be nObs long and contain 1 or 2 integers only"
  )
  v$check(
    test_int(object@nextPart, lower = 1, upper = 2),
    "nextPart must be integer scalar 1 or 2"
  )
  v$check(
    test_numeric(
      object@part1Ladder,
      any.missing = FALSE,
      sorted = TRUE,
      unique = TRUE
    ),
    "part1Ladder must be of type double and contain unique, sorted values"
  )
  v$check(
    test_subset(object@part1Ladder, object@doseGrid),
    "part1Ladder must have all entries from doseGrid"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataMixture`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_mixture <- function(object) {
  v <- Validate()

  # In if clause so that below test_* won't fail.
  if (!test_int(object@nObsshare)) {
    return("nObsshare must be of type integer of length 1")
  }
  v$check(
    test_numeric(object@xshare, len = object@nObsshare, any.missing = FALSE),
    "Dose vector xshare must be of type double and length nObsshare"
  )
  v$check(
    test_integer(
      object@yshare,
      lower = 0,
      upper = 1,
      len = object@nObsshare,
      any.missing = FALSE
    ),
    "DLT vector yshare must be nObsshare long and contain 0 or 1 integers only"
  )
  v$check(
    test_subset(object@xshare, object@doseGrid),
    "Dose values in xshare must be from doseGrid"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataDA`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_da <- function(object) {
  v <- Validate()
  # In if clause so that below test_* won't fail.
  if (!(test_number(object@Tmax) && object@Tmax > 0)) {
    return(
      "DLT window Tmax must be of type double of length 1 and greater than 0"
    )
  }
  v$check(
    test_numeric(
      object@u,
      upper = object@Tmax,
      len = object@nObs,
      any.missing = FALSE
    ) &&
      all(object@u >= 0),
    "u must be of type double, nObs length, non-negative, not missing and not greater than Tmax"
  )
  v$check(
    test_numeric(
      object@t0,
      lower = 0,
      len = object@nObs,
      any.missing = FALSE,
      sorted = TRUE
    ),
    "t0 must be of type double, nObs length, sorted non-negative"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataOrdinal`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_ordinal <- function(object) {
  v <- h_validate_common_data_slots(object)
  v$check(
    test_integer(
      object@y,
      lower = 0,
      upper = length(object@yCategories) - 1,
      len = object@nObs,
      any.missing = FALSE
    ),
    "DLT vector y must be nObs long and contain integers between 0 and k-1 only, where k is the length of the vector in the yCategories slot" # nolint
  )
  v$check(
    length(unique(names(object@yCategories))) ==
      length(names(object@yCategories)),
    "yCategory labels must be unique"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataGrouped`] object
#'   contains valid group information.
v_data_grouped <- function(object) {
  v <- Validate()
  v$check(
    test_factor(
      object@group,
      levels = c("mono", "combo"),
      len = object@nObs,
      any.missing = FALSE
    ),
    "group must be factor with levels mono and combo of length nObs without missings"
  )
  v$result()
}

# tidy ----

## generic ----

#' Tidying `CrmPackClass` objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' In the spirit of the `broom` package, provide a method to convert a
#' `CrmPackClass` object to a (list of) tibbles.
#'
#' @param x (`CrmPackClass`)\cr the object to be tidied.
#' @param ... potentially used by class-specific methods
#'
#' @return A (list of) tibble(s) representing the object in tidy form.
#'
#' @export
#'
setGeneric(
  name = "tidy",
  def = function(x, ...) {
    standardGeneric("tidy")
  }
)

## CrmPackClass ----

#' Tidy a `CrmPackClass` Object
#'
#' Following the principles of the `broom` package, convert a `CrmPackClass`
#' object to a (list of) tibbles.  This is a basic, default representation.
#'
#' @param x (`CrmPackClass`)\cr the object to be tidied.
#' @param ... potentially used by class-specific methods.
#' @rdname tidy
#' @aliases tidy-CrmPackClass
#' @keywords methods
#' @example examples/CrmPackClass-method-tidy.R
#'
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CrmPackClass"),
  definition = function(x, ...) {
    rv <- h_tidy_all_slots(x) %>% h_tidy_class(x)
    if (length(rv) == 1) {
      rv[[names(rv)[1]]] %>% h_tidy_class(x)
    } else {
      rv
    }
  }
)

# Integration with knitr ----
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' We provide additional utility functions to allow human-friendly rendition of
#' crmPack objects in Markdown and Quarto files
#'
#' @return a character string that represents the object in markdown.
#' @name knit_print
NULL

# Helpers ---

#' Helper Function to Convert a `gap` Slot to Words
#'
#' @inheritParams knit_print.SafetyWindowConst
#' @param gap (`numeric`)\cr a vector of gaps
#' @return a Markdown representation of the `gap` parameter as a bullet list.
#' @noRd
#' @keywords internal
h_describe_safety_gap <- function(gap, ordinals, label, time_unit) {
  assert_character(
    ordinals,
    min.len = length(gap) - 1,
    any.missing = FALSE,
    unique = TRUE
  )

  if (length(gap) == 1) {
    paste0(
      "- The gap between consecutive enrolments should always be at least ",
      gap[1],
      " ",
      ifelse(gap[1] == 1, time_unit[1], time_unit[2]),
      ".\n\n"
    )
  } else {
    paste0(
      paste0(
        lapply(
          seq_along(1:(length(gap) - 1)),
          function(n) {
            paste0(
              "-  The gap between the enrolment of the ",
              ordinals[n],
              " and the ",
              ordinals[n + 1],
              " ",
              label[2],
              " in the cohort should be at least ",
              gap[n],
              " ",
              ifelse(gap[n] == 1, time_unit[1], time_unit[2])
            )
          }
        ),
        collapse = "\n\n"
      ),
      "\n",
      paste0(
        "- The gap between all subsequent ",
        label[2],
        " should be at least ",
        gap[length(gap)],
        " ",
        ifelse(gap[length(gap)] == 1, time_unit[1], time_unit[2]),
        "\n"
      ),
      sep = "\n"
    )
  }
}
# Methods ----

# SafetyWindow ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @inheritParams knit_print.CohortSizeConst
#' @section Usage Notes:
#' `label` should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a count of 1 and the second describes all other counts.
#' If of length 1, the character `s` is appended to the value when the count is not 1.
#' @rdname knit_print
#' @export
#' @method knit_print SafetyWindow
knit_print.SafetyWindow <- function(
  x,
  ...,
  asis = TRUE,
  time_unit = "day",
  label = "participant"
) {
  assert_character(time_unit, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_flag(asis)

  label <- h_prepare_labels(label)
  if (length(time_unit) == 1) {
    time_unit[2] <- paste0(time_unit[1], "s")
  }

  rv <- paste0(
    "To protect the welfare of individual ",
    label[2],
    ", the rate of enrolment within each cohort will be restricted.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# SafetyWindowConst ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @inheritParams knit_print.CohortSizeConst
#' @param time_unit (`character`)\cr the word used to describe units of time.
#' See Usage Notes below.
#' @param ordinals (`character`)\cr a character vector whose nth defines the
#' word used as the written representation of the nth ordinal number.
#' @section Usage Notes:
#' `label` and `time_unit` are, collectively, labels.
#'
#' A label should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a count of 1 and the second describes all other counts.
#' If of length 1, the character `s` is appended to the value when the count is not 1.
#' @rdname knit_print
#' @export
#' @method knit_print SafetyWindowConst
knit_print.SafetyWindowConst <- function(
  x,
  ...,
  asis = TRUE,
  label = "participant",
  ordinals = c(
    "first",
    "second",
    "third",
    "fourth",
    "fifth",
    "sixth",
    "seventh",
    "eighth",
    "ninth",
    "tenth"
  ),
  time_unit = "day"
) {
  assert_character(time_unit, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_character(
    ordinals,
    min.len = length(x@gap) - 1,
    any.missing = FALSE,
    unique = TRUE
  )
  assert_flag(asis)

  label <- h_prepare_labels(label)
  if (length(time_unit) == 1) {
    time_unit[2] <- paste0(time_unit[1], "s")
  }

  rv <- paste0(
    knit_print.SafetyWindow(x, asis = FALSE, label = label, ...),
    "For all cohorts:\n\n",
    h_describe_safety_gap(x@gap, ordinals, label, time_unit),
    "Before the next cohort can open, all ",
    label[2],
    " in the current cohort must have been followed up for at least ",
    x@follow,
    " ",
    ifelse(x@follow == 1, time_unit[1], time_unit[2]),
    " and at least one ",
    label[1],
    " must have been followed up for at least ",
    x@follow_min,
    " ",
    ifelse(x@follow_min == 1, time_unit[1], time_unit[2]),
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# SafetyWindowSize ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.SafetyWindowConst
#' @inherit SafetyWindowConst sections
#' @param level (`count`)\cr the markdown level at which the headings for cohort size
#' will be printed.  An integer between 1 and 6
#' @rdname knit_print
#' @export
#' @method knit_print SafetyWindowSize
knit_print.SafetyWindowSize <- function(
  x,
  ...,
  asis = TRUE,
  # We could use package english here and avoid the need for `ordinals`, but
  # is an extra dependency for very limited benefit
  ordinals = c(
    "first",
    "second",
    "third",
    "fourth",
    "fifth",
    "sixth",
    "seventh",
    "eighth",
    "ninth",
    "tenth"
  ),
  label = "participant",
  time_unit = "day",
  level = 2L
) {
  assert_character(time_unit, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_flag(asis)
  assert_integer(level, lower = 1, upper = 6, any.missing = FALSE)

  label <- h_prepare_labels(label)
  if (length(time_unit) == 1) {
    time_unit[2] <- paste0(time_unit[1], "s")
  }

  rv <- paste0(
    knit_print.SafetyWindow(x, asis = FALSE, label = label, ...),
    paste0(
      lapply(
        seq_along(x@size),
        function(i) {
          paste0(
            dplyr::case_when(
              i == 1 ~
                paste0(
                  stringr::str_dup("#", level),
                  " For cohort sizes of less than ",
                  x@size[2]
                ),
              i == length(x@size) ~
                paste0(
                  stringr::str_dup("#", level),
                  " For cohort sizes of ",
                  x@size[i],
                  " or more"
                ),
              TRUE ~
                paste0(
                  stringr::str_dup("#", level),
                  " For cohort sizes greater than or equal to ",
                  x@size[i],
                  " and strictly less than ",
                  x@size[i + 1]
                )
            ),
            "\n\n",
            h_describe_safety_gap(x@gap[[i]], ordinals, label, time_unit)
          )
        }
      ),
      collapse = "\n"
    )
  )

  rv <- paste0(
    rv,
    "For all cohorts, before the next cohort can open, all ",
    label[2],
    " in the current cohort must have been followed up for at least ",
    x@follow,
    " ",
    ifelse(x@follow == 1, time_unit[1], time_unit[2]),
    " and at least one ",
    label[1],
    " must have been followed up for at least ",
    x@follow_min,
    " ",
    ifelse(x@follow_min == 1, time_unit[1], time_unit[2]),
    ".\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Check That Labels Are Valid and Useful
#'
#' A vector of labels is valid and useful if it is of length 2, of type character
#' and its values are distinct.
#'
#' If `x` is a scalar, a second element is added, whose value is the value of the
#' scalar with "s" appended.  If `x` is `"toxicity"`, the plural is handled appropriately.
#'
#' @param x (`character`)\cr The vector to be checked
#' @keywords internal
#' @return a character vector of length 2 whose values are distinct
h_prepare_labels <- function(x) {
  assert_character(
    x,
    min.len = 1,
    max.len = 2,
    any.missing = FALSE,
    unique = TRUE
  )

  if (length(x) == 1) {
    if (x == "toxicity") {
      x <- c("toxicity", "toxicities")
    } else {
      x[2] <- paste0(x[1], "s")
    }
  }
  x
}

#' Append Units to a Numeric Dose
#'
#' @param units (`character`)\cr the units to be displayed
#' @keywords internal
#' @return if `units` is `NA`, then `NA`.  Otherwise, `units`, ensuring that exactly
#' one space precedes the first non-whitespace character
h_prepare_units <- function(units = NA) {
  assert_character(units, len = 1)

  ifelse(
    is.na(units),
    "",
    paste0(" ", stringr::str_trim(units, "left"))
  )
}

#' @include McmcOptions-class.R
#' @include Samples-validity.R
#' @include CrmPackClass-class.R
NULL

# Samples ----

## class ----

#' `Samples`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Samples`] is the class to store the MCMC samples.
#'
#' @slot data (`list`)\cr MCMC samples of the parameter. Each entry in this list
#'   must be a vector (in case of a scalar parameter) or matrix (in case of a
#'   vector-valued parameter) with samples.
#'   In case of matrix, every row is a separate sample, while columns correspond
#'   to the dimension of the parameter.
#' @slot options (`McmcOptions`)\cr MCMC options that were used to generate the
#'   samples.
#'
#' @aliases Samples
#' @export
#'
.Samples <- setClass(
  Class = "Samples",
  slots = c(
    data = "list",
    options = "McmcOptions"
  ),
  prototype = prototype(
    data = list(),
    options = McmcOptions()
  ),
  contains = "CrmPackClass",
  validity = v_samples
)

## constructor ----

#' @rdname Samples-class
#'
#' @param data see slot definition.
#' @param options see slot definition.
#'
#' @export
#' @example examples/Samples-class.R
#'
Samples <- function(data, options) {
  new("Samples", data = data, options = options)
}

## default constructor ----

#' @rdname Samples-class
#' @note Typically, end users will not use the `.DefaultSamples()` function.
#' @export
.DefaultSamples <- function() {
  mcmc(
    data = .DefaultData(),
    model = .DefaultLogisticLogNormal(),
    options = .DefaultMcmcOptions()
  )
}

#' Helpers for stripping expressions of `covr`-inserted trace code
#'
#' Workarounds to allow the package to continue to work while running `covr`
#' with minimal changes to the package code.
#'
#' @details
#' When using `covr`, the source code for package objects are modified to add
#' callbacks for each expression to log its execution. Given an arbitrary
#' expression, such as:
#'
#'     expr
#'
#' The code will be modified before executing any package code to look like:
#'
#'     if (TRUE) {
#'       covr:::count("file.R:1:2:3:4:5:6:7:8")
#'       expr
#'     }
#'
#' These functions are used for stripping expressions of this code so that the
#' package continues to work as intended while running tests as part of running
#' `covr` to calculate package coverage.
#'
#' This method is non-exhaustive, covering only a subset of `covr`'s tracing
#' behaviors necessary for this package.
#'
#' @param expr (`language`)\cr an R expression or call to test or strip of
#'   `covr` trace counters.
#'
#' @return A logical value or transformed expression with calls to
#'   `covr:::count` removed.
#'
#' @name h_covr_helpers
#' @keywords internal
#'
NULL

#' @describeIn h_covr_helpers
#' Determine whether `covr` is currently running
h_covr_active <- function() {
  identical(Sys.getenv("R_COVR"), "true")
}

#' @describeIn h_covr_helpers
#' Remove `covr` traces from an expression
h_covr_detrace <- function(expr) {
  if (!h_covr_active()) {
    return(expr)
  }

  if (is.function(expr)) {
    body(expr) <- h_covr_detrace(body(expr))
    return(expr)
  }

  detrace <- function(x) {
    # returns "missing" expression to avoid errors with calls
    if (identical(x, bquote())) {
      return(x)
    }

    x <- h_covr_detrace_call(x)
    if (is.call(x)) {
      x[-1] <- lapply(x[-1], h_covr_detrace)
    }
    x
  }

  detrace(expr)
}

#' @describeIn h_covr_helpers
#' Determine whether the current expression is a `covr`-modified expression
h_is_covr_trace <- function(expr) {
  # Matches `if (TRUE) { covr:::count(<trace>); <expr> }` (see covr:::trace_calls).
  is.call(expr) &&
    expr[[1]] == "if" &&
    expr[[2]] == quote(TRUE) &&
    expr[[3]][[1]] == "{" &&
    length(expr[[3]]) >= 3 &&
    is.call(expr[[3]][[2]]) &&
    expr[[3]][[2]][[1]] == call(":::", as.symbol("covr"), as.symbol("count"))
}

#' @describeIn h_covr_helpers
#' Extract the original expression from a `covr`-modified expression
h_covr_detrace_call <- function(expr) {
  if (h_is_covr_trace(expr)) expr[[3]][[3]] else expr
}

#' Convenience function to make barplots of percentages
#'
#' @param x vector of samples
#' @param description xlab string
#' @param xaxisround rounding for xaxis labels (default: 0, i.e. integers will
#' be used)
#'
#' @return the ggplot2 object
#'
#' @keywords internal
#' @importFrom ggplot2 ggplot geom_histogram aes xlab ylab xlim
h_barplot_percentages <- function(x, description, xaxisround = 0) {
  assert_number(xaxisround, lower = 0)
  assert_character(description, len = 1, any.missing = FALSE)
  assert_numeric(x)

  tabx <- table(x) / length(x)
  dat <- data.frame(x = as.numeric(names(tabx)), perc = as.numeric(tabx) * 100)
  ggplot() +
    geom_bar(
      aes(x = x, y = perc),
      data = dat,
      stat = "identity",
      position = "identity",
      width = ifelse(nrow(dat) > 1, min(diff(dat$x)) / 2, 1)
    ) +
    xlab(description) +
    ylab("Percent") +
    scale_x_continuous(
      breaks = round(dat$x, xaxisround)
    )
}


#' Helper function to calculate percentage of true stopping rules for
#' report label output
#' calculates true column means and converts output into percentages
#' before combining the output with the report label; output is passed
#' to [`show()`] and output with cat to console
#'
#' @param stop_report object from summary method
#' @return named list with label and percentage of rule activation

h_calc_report_label_percentage <- function(stop_report) {
  stop_pct <- colMeans(stop_report) * 100
  stop_pct_to_print <- stop_pct[!is.na(names(stop_pct))]
  return(stop_pct_to_print)
}


#' Helper function to calculate average across iterations for each additional
#' reporting parameter
#' extracts parameter names as specified by user and averaged the values
#' for each specified parameter to [`show()`] and output with cat to console
#'
#' @param stats_list object from simulation with nested parameter values
#' (sublist for each parameter)
#' @return list of parameter names and averaged values for console output

h_summarize_add_stats <- function(stats_list) {
  # Extract the parameter names
  param_names <- names(stats_list[[1]])

  # Calculate the average for each parameter
  averages <- lapply(param_names, function(param) {
    values <- sapply(stats_list, function(x) x[[param]])
    mean(values)
  })

  return(list(param_names, averages))
}

#' Verbose Logging
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A family of wrappers of selected [`futile.logger`] functions that control
#' the logging mechanism in `crmPack`. The `crmPack` uses [`futile.logger`]
#' package for the logging purposes. All the messages logged in `crmPack` are
#' logged into `crmPack` logger at the [`futile.logger::TRACE`] level. Hence,
#' enabling verbose logging means that the logging threshold will be set to
#' [`futile.logger::TRACE`] for the `crmPack` logger, and disabling verbose
#' logging means that it will be set to [`futile.logger::FATAL`].
#'
#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.threshold()] that enables `crmPack` verbose logging by
#'   setting logging threshold to [`futile.logger::TRACE`] for `crmPack` logger.
#'
#' @export
#'
enable_logging <- function() {
  invisible(
    futile.logger::flog.threshold(futile.logger::TRACE, name = "crmPack")
  )
}

#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.threshold()] that disables `crmPack` verbose logging
#'   by setting logging threshold to [`futile.logger::FATAL`] for `crmPack`
#'   logger.
#'
#' @export
#'
disable_logging <- function() {
  invisible(
    futile.logger::flog.threshold(futile.logger::FATAL, name = "crmPack")
  )
}

#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.logger()] that checks whether current threshold level
#'   for `crmPack` logger is verbose, which is [`futile.logger::TRACE`].
#'   It returns `TRUE` if the current logging level is verbose, `FALSE`
#'   otherwise.
#'
#' @export
#'
is_logging_enabled <- function() {
  logger <- futile.logger::flog.logger(name = "crmPack")
  unname(logger$threshold == futile.logger::TRACE)
}

#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.trace()] that prints a log message in the `crmPack`
#'   logger.
#'
#' @inheritParams futile.logger::flog.trace
#'
#' @export
#'
log_trace <- function(msg, ..., capture = FALSE) {
  assert_string(msg)
  assert_flag(capture)

  futile.logger::flog.trace(msg = msg, ..., name = "crmPack", capture = capture)
}

#' @include helpers.R
#' @include ModelParams-validity.R
#' @include CrmPackClass-class.R
NULL

# ModelParamsNormal ----

## class ----

#' `ModelParamsNormal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`ModelParamsNormal`] is the class for a bivariate normal model parameters,
#' i.e. the mean vector, covariance matrix and precision matrix.
#' The precision matrix is an inverse of the covariance matrix in the
#' `JAGS` and it is computed internally by the object constructor function.
#'
#' @slot mean (`numeric`)\cr the mean vector.
#' @slot cov (`matrix`)\cr the covariance matrix.
#' @slot prec (`matrix`)\cr the precision matrix, which is an inverse matrix of the `cov`.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormalMixture`].
#'
#' @aliases ModelParamsNormal
#' @export
#'
.ModelParamsNormal <- setClass(
  Class = "ModelParamsNormal",
  slots = c(
    mean = "numeric",
    cov = "matrix",
    prec = "matrix"
  ),
  contains = "CrmPackClass",
  validity = v_model_params_normal
)

## constructor ----

#' @rdname ModelParamsNormal-class
#'
#' @param mean (`numeric`)\cr the prior mean vector.
#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
#'   `prec` is internally calculated as an inverse of `cov`.
#'
#' @export
#' @examples
#' ModelParamsNormal(mean = c(1, 6), cov = diag(2))
ModelParamsNormal <- function(mean, cov) {
  assert_matrix(
    cov,
    mode = "numeric",
    any.missing = FALSE,
    nrows = length(mean),
    ncols = length(mean)
  )
  # To ensure that `cov` is invertible:
  assert_true(h_is_positive_definite(cov, length(mean)))

  .ModelParamsNormal(
    mean = mean,
    cov = cov,
    prec = solve(cov)
  )
}

## default constructor ----

#' @rdname ModelParamsNormal-class
#' @note Typically, end users will not use the `.ModelPAramsNormal()` function.
#' @export
.DefaultModelParamsNormal <- function() {
  ModelParamsNormal(
    mean = c(1, 0),
    cov = matrix(c(1, 0, 0, 1), nrow = 2)
  )
}

#' @include McmcOptions-methods.R
NULL

# v_samples ----

#' Internal Helper Functions for Validation of [`Samples`] Objects
#'
#' @description These functions are only used internally to validate the format
#'   of an input [`Samples`] or inherited classes and therefore not exported.
#'
#' @name v_samples_objects
#' @param object (`Samples`)\cr object to validate.
#' @return A `character` vector with the validation failure messages, or `TRUE`
#'   in case validation passes.
NULL

#' @describeIn v_samples_objects validates that the [`Samples`] object contains
#'   valid `data` slot.
v_samples <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@data, NROW) == size(object@options)),
    "Every element in data must be of the same length (no. of rows) as the sample size was"
  )
  v$check(
    all(sapply(object@data, test_numeric, finite = TRUE, any.missing = FALSE)),
    "Every element in data must be a finite object of type integer or double"
  )
  v$result()
}

# nolint start

#' Object-oriented implementation of CRM designs
#'
#' @name crmPack
#' @title Object-oriented implementation of CRM designs
#' @import checkmate
#' @import ggplot2
#' @import methods
#' @import tibble
#' @importFrom grid grid.draw
#' @importFrom gridExtra arrangeGrob
#' @importFrom graphics plot hist legend lines matlines matplot
#' @importFrom stats binomial coef cov2cor gaussian glm lm median model.matrix
#'   optim pgamma plogis pnorm qgamma qlogis qnorm quantile rbinom rgamma
#'   approxfun rnorm runif uniroot var vcov step mad pbeta dbeta dgamma
#'   setNames
#' @importFrom utils data head tail capture.output
#' @importFrom lifecycle badge
#' @importFrom rjags jags.model jags.samples
#' @importFrom futile.logger flog.threshold flog.logger flog.trace TRACE FATAL
#' @importFrom knitr knit_print
#' @importFrom kableExtra kbl add_header_above column_spec collapse_rows
#'   kable_styling add_footnote kable
#'
#' @keywords package
#' @references Sabanes Bove D, Yeung WY, Palermo G, Jaki T (2019).
#' "Model-Based Dose Escalation Designs in R with crmPack."
#' Journal of Statistical Software, 89(10), 1-22.
#' doi:10.18637/jss.v089.i10 (URL: http://doi.org/10.18637/jss.v089.i10).
"_PACKAGE"

##' @keywords internal
.onAttach <- function(libname, pkgname) {
  packageStartupMessage(
    "Type crmPackHelp() to open help browser\n",
    "Type crmPackExample() to open example\n"
  )
}

## need to declare global variable / function
## names in order to avoid R CMD check notes:
globalVariables(c(
  "log.betaZ",
  "precW",
  "pow",
  "nObs",
  "betaZ",
  "x",
  "betaW",
  "xLevel",
  "precW",
  "z",
  "nGrid",
  "doseGrid",
  "betaWintercept",
  "delta",
  "deltaStart",
  "delta2",
  "Effsamples",
  "logit<-",
  "rho0",
  "alpha0",
  "delta0",
  "alpha1",
  "delta1",
  "inverse",
  "priorCov",
  "theta",
  "comp0",
  "w",
  "DLTs",
  "y",
  "group",
  "annotate",
  "probSamples",
  "prec",
  "nu",
  "samples",
  "Type",
  "patient",
  "toxicity",
  "ID",
  "biomarker",
  "traj",
  "Statistic",
  "perc",
  "..density..",
  "middle",
  "lower",
  "upper",
  "middleBiomarker",
  "lowerBiomarker",
  "upperBiomarker",
  "nObsshare",
  "xshare",
  "yshare",
  "thisProb.PL",
  "thisMeanEff.PL",
  "thisSize.PL",
  "probit<-",
  "refDose",
  "Tmax",
  "u",
  "eps",
  "h",
  "lambda",
  "cadj",
  "A",
  "lambda_p",
  "cond",
  "t0",
  "tend",
  "t0_case",
  "tend_case",
  "yhat",
  "ref_dose",
  "comp",
  "X",
  "skel_probs",
  "is_combo",
  "results",
  "k",
  "value",
  "Parameter",
  "intervals",
  "Group",
  "Tox",
  "MaxOverdoseProb",
  "DoseGrid",
  "NGrid",
  "NObs",
  "XLevel"
))

# nolint end

1		#' @include helpers.R
2		#' @include McmcOptions-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# McmcOptions ----
7
8		## class ----
9
10		#' `McmcOptions`
11		#'
12		#' @description `r lifecycle::badge("stable")`
13		#'
14		#' [`McmcOptions`] is a class for the three canonical MCMC options as well as
15		#' Random Number Generator settings.
16		#'
17		#' @slot iterations (`count`)\cr number of MCMC iterations.
18		#' @slot burnin (`count`)\cr number of burn-in iterations which are not saved.
19		#' @slot step (`count`)\cr only every `step`-th iteration is saved after
20		#' the `burnin`. In other words, a sample from iteration
21		#' `i = 1,...,iterations`, is saved if and only if
22		#' `(i - burnin) mod step = 0`.\cr
23		#' For example, for `iterations = 6`, `burnin = 0` and `step = 2`, only
24		#' samples from iterations `2,4,6` will be saved.
25		#' @slot rng_kind (`string`)\cr a Random Number Generator (RNG) type used by
26		#' [`rjags`]. It must be one out of the following four values:
27		#' `base::Wichmann-Hill`, `base::Marsaglia-Multicarry`,
28		#' `base::Super-Duper`, `base::Mersenne-Twister`, or `NA_character_`.
29		#' If it is `NA_character_` (default), then the RNG kind will be chosen by
30		#' [`rjags`].
31		#' @slot rng_seed (`number`)\cr a Random Number Generator (RNG) seed
32		#' used by [`rjags`] for a chosen `rng_kind`. It must be an integer scalar or
33		#' `NA_integer_`, which means that the seed will be chosen by [`rjags`].
34		#'
35		#' @aliases McmcOptions
36		#' @export
37		#'
38		.McmcOptions <- setClass(
39		Class = "McmcOptions",
40		slots = c(
41		iterations = "integer",
42		burnin = "integer",
43		step = "integer",
44		rng_kind = "character",
45		rng_seed = "integer"
46		),
47		prototype = prototype(
48		iterations = 1000L,
49		burnin = 100L,
50		step = 2L,
51		rng_kind = NA_character_,
52		rng_seed = NA_integer_
53		),
54		contains = "CrmPackClass",
55		validity = v_mcmc_options
56		)
57
58		## constructor ----
59
60		#' @rdname McmcOptions-class
61		#'
62		#' @param burnin (`count`)\cr number of burn-in iterations which are not saved.
63		#' @param step (`count`)\cr only every step-th iteration is saved after
64		#' the burn-in.
65		#' @param samples (`count`)\cr number of resulting samples.
66		#' @param rng_kind (`string`)\cr the name of the RNG type. Possible types are:
67		#' `Wichmann-Hill`, `Marsaglia-Multicarry`, `Super-Duper`, `Mersenne-Twister`.
68		#' If it is `NA` (default), then the RNG kind will be chosen by `[rjags`].
69		#' @param rng_seed (`number`)\cr RNG seed corresponding to chosen `rng_kind`.
70		#' It must be an integer value or `NA` (default), which means that the seed
71		#' will be chosen by `[rjags`].
72		#'
73		#' @export
74		#' @example examples/McmcOptions-class-McmcOptions.R
75		#'
76		McmcOptions <- function(
77		burnin = 1e4L,
78		step = 2L,
79		samples = 1e4L,
80		rng_kind = NA_character_,
81		rng_seed = NA_integer_
82		) {
83	2360x	assert_count(burnin, positive = TRUE)
84	2360x	assert_count(step, positive = TRUE)
85	2360x	assert_count(samples, positive = TRUE)
86	2360x	assert_string(rng_kind, na.ok = TRUE)
87	2360x	assert_count(rng_seed, na.ok = TRUE)
88
89	2360x	if (!is.na(rng_kind)) {
90	351x	rng_kind <- paste0("base::", rng_kind)
91		} else {
92	2009x	rng_kind <- NA_character_
93		}
94	2360x	if (!is.na(rng_seed)) {
95	350x	rng_seed <- as.integer(rng_seed)
96		} else {
97	2010x	rng_seed <- NA_integer_
98		}
99
100	2360x	.McmcOptions(
101	2360x	iterations = as.integer(burnin + (step * samples)),
102	2360x	burnin = as.integer(burnin),
103	2360x	step = as.integer(step),
104	2360x	rng_kind = rng_kind,
105	2360x	rng_seed = as.integer(rng_seed)
106		)
107		}
108
109		## default constructor ----
110
111		#' @rdname McmcOptions-class
112		#' @note Typically, end users will not use the `.DefaultMcmcOptions()` function.
113		#' @export
114		.DefaultMcmcOptions <- function() {
115	13x	McmcOptions(
116	13x	burnin = 250,
117	13x	samples = 1000
118		)
119		}

1		#' Convert Object's Attributes to a Tibble
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' A helper function that interrogates an object to see if it has attributes
6		#' and, if so, converts them to a (list of) tibbles. Columns are named after
7		#' attributes. If attributes have different lengths but recycling is possible,
8		#' a single `tibble` is returned. Otherwise, a `list` of tibbles is returned.
9		#'
10		#' @param x (`CrmPackObject`)\cr object whose attributes will be interrogated.
11		#' @param .ignore (`character`)\cr names of attrributes to be ignored.
12		#'
13		#' @return A [`tibble`] or `list` of [`tibble`]s containg the values of the
14		#' object's attributes.
15		#'
16		#' @keywords internal
17		#' @noRd
18		h_handle_attributes <- function(
19		x,
20		.ignore = c("names", "class", "description", "row.names")
21		) {
22	3x	a <- attributes(x)
23	3x	valid_names <- setdiff(names(a), .ignore)
24	3x	lapply(
25	3x	valid_names,
26	3x	function(n) {
27	18x	z <- attr(x, n)
28	18x	rv <- NULL
29		# Some Design classes have attributes that are functions or CrmPackClass objects
30	18x	if (!is.function(z)) {
31	18x	if (length(z) == 1) {
32	18x	if (is(z, "CrmPackClass")) {
33	!	z <- z %>% tidy()
34		}
35	18x	rv <- tibble::tibble(X = z)
36		} else {
37	!	if (length(z) == 0) {
38	!	rv <- tibble::tibble(X = NA)
39		} else {
40	!	if (is(z, "CrmPackClass")) {
41	!	rv <- z %>% tidy()
42		} else {
43	!	rv <- tibble::tibble(X = list(z))
44		}
45		}
46		}
47	18x	names(rv) <- n
48		}
49	18x	rv
50		}
51		) %>%
52	3x	dplyr::bind_cols()
53		}
54
55		#' Tidy a Single Slot of a CrmPackObject
56		#'
57		#' @description `r lifecycle::badge("experimental")`
58		#'
59		#' A helper function that converts a single slot of a `CrmPackObject` to a tibble.
60		#' If the slots value is a `list`, each element of the list is tidied individually.
61		#'
62		#' @param obj (`CrmPackObject`)\cr object to be converted.
63		#' @param slot_name (`character`)\cr name of the slot to be tidied.
64		#' @param col (`character`)\cr The name of the corresponding column in the tidied
65		#' tibble. Defaults to `slot_name`.
66		#' @param attributes (`flag`)\cr shoud the object's attributes, if any, be added
67		#' to the output tibble
68		#'
69		#' @return A [`tibble`]
70		#'
71		#' @keywords internal
72		#' @importFrom rlang :=
73		#' @noRd
74		h_tidy_slot <- function(obj, slot_name, col = NULL, attributes = FALSE) {
75	2342x	if (is.list(slot(obj, slot_name))) {
76	57x	return(
77	57x	lapply(
78	57x	slot(obj, slot_name),
79	57x	function(x) {
80	116x	if (is.data.frame(x)) {
81	6x	return(x)
82	57x	} else if (
83	110x	is.list(x) &&
84	110x	stringr::str_detect(class(x)[1], stringr::fixed("tbl_"))
85		) {
86		# Already tidied to a list.
87	!	return(x)
88	110x	} else if (is.numeric(x) \| is.character(x)) {
89		# tidy.numeric & tidy.character are deprecated
90	12x	return(tibble::tibble(!!{{ slot_name }} := x))
91		} else {
92	98x	return(x %>% tidy())
93		}
94		}
95		)
96		)
97		}
98	2285x	if (is(slot(obj, slot_name), "CrmPackClass")) {
99	302x	rv <- slot(obj, slot_name) %>%
100	302x	tidy()
101		} else {
102	1983x	if (is.null(col)) {
103	1983x	col <- slot_name
104		}
105	1983x	rv <- tibble::tibble({{ col }} := slot(obj, slot_name))
106		}
107	2285x	if (attributes) {
108	!	a <- h_handle_attributes(slot(obj, slot_name))
109	!	if (nrow(a) > 0) {
110	!	rv <- rv %>% dplyr::bind_cols(a)
111		}
112		}
113	2285x	rv
114		}
115
116		#' Tidy All Slots of a CrmPackObject
117		#'
118		#' @description `r lifecycle::badge("experimental")`
119		#'
120		#' A helper function that converts all the slots of a `CrmPackObject` to a
121		#' (list of) tibble(s).
122		#'
123		#' @param obj (`CrmPackObject`)\cr object to be tidied.
124		#' @param ... passed to h_tidy_slot
125		#'
126		#' @return A (list of) [`tibble`](s)
127		#'
128		#' @keywords internal
129		#' @noRd
130		h_tidy_all_slots <- function(obj, ...) {
131	676x	slot_names <- slotNames(obj)
132	676x	rv <- list()
133	676x	for (nm in slot_names) {
134	2552x	if (!is.function(slot(obj, nm))) {
135	2292x	rv[[nm]] <- h_tidy_slot(obj, nm, ...)
136		}
137		}
138		# Column bind of all list elements have the same number of rows
139	676x	if (length(rv) > 1 && length(unique(sapply(rv, nrow))) == 1) {
140	369x	rv <- rv %>% dplyr::bind_cols() # nolint
141		}
142	676x	rv
143		}
144
145		#' Amend the Class of a Tibble to Indicate that it Contains a Tidied `CrmPackObject`
146		#'
147		#' @description `r lifecycle::badge("experimental")`
148		#'
149		#' A helper function that prepends `tbl_<cls>`, where `<cls>` is the first
150		#' element of the class attribute of the original `CrmPackObject` to the class
151		#' attribute of a tibble
152		#'
153		#' @param d (`tibble`)\cr the tibble containing the tidied version of `obj`.
154		#' @param obj (`CrmPackObject`)\cr object to be converted.
155		#'
156		#' @return `d`, with an amended class attribute
157		#'
158		#' @keywords internal
159		#' @noRd
160		h_tidy_class <- function(d, obj) {
161	1181x	cls <- class(obj)
162	1181x	class(d) <- c(paste0("tbl_", cls[1]), class(d))
163	1181x	d
164		}
165
166		#' Convert a `CrmPackObject`'s "Interval list" to a Min-Max
167		#'
168		#' @description `r lifecycle::badge("experimental")`
169		#'
170		#' `CrmPackClass` objects that define a set of intervals (such as `CohortSizeRange`)
171		#' typically contain a left-open vector that dfines the intervals. For example,
172		#' `my_size <- CohortSizeRange(intervals = c(0, 20), cohort_size = c(1, 3))` defines
173		#' two dose ranges: [0, 20) and [20, Inf). This is convenient for coding, but
174		#' awkward for reporting. This helper function converts this single-column
175		#' representation to a two-column representation that explicitly defines the
176		#' lower and upper ends of each interval. Using the example above, the converted
177		#' tibble would look like this:
178		#'
179		#' \| cohort_size \| min \| max \|
180		#' \| ----------: \| ---: \| ---: \|
181		#' \| 1 \| -Inf \| 20 \|
182		#' \| 3 \| 20 \| Inf \|
183		#'
184		#' @param x (`tibble`)\cr the tibble to be converted.
185		#' @param col (`tidy-eval`)\cr column containing the intervals.
186		#' @param min_col (`character`)\cr name of the column containing the lower end
187		#' of the interval in the returned value.
188		#' @param max_col (`character`)\cr name of the column containing the upper end
189		#' of the interval in the returned value.
190		#' @param range_min (`numeric`)\cr value of the lower end of the first interval.
191		#' @param range_max (`numeric`)\cr value of the upper end of the last interval.
192		#'
193		#' @return A `tibble` in min-max format, with one row more than the input tibble.
194		#'
195		#' @importFrom rlang :=
196		#' @keywords internal
197		#' @noRd
198		h_range_to_minmax <- function(
199		x,
200		col,
201		min_col = "min",
202		max_col = "max",
203		range_min = -Inf,
204		range_max = Inf
205		) {
206	242x	vals <- x %>% dplyr::pull({{ col }})
207	242x	tibble(
208	242x	{{ min_col }} := c(range_min, vals),
209	242x	{{ max_col }} := c(vals, range_max)
210		)
211		}

1		#' @include helpers.R
2		#' @include Data-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# GeneralData-class ----
7
8		#' `GeneralData`
9		#'
10		#' @description `r lifecycle::badge("stable")`
11		#'
12		#' [`GeneralData`] is a class for general data input.
13		#'
14		#' @slot ID (`integer`)\cr unique patient IDs.
15		#' @slot cohort (`integer`)\cr the cohort (non-negative sorted) indices.
16		#' @slot nObs (`integer`)\cr number of observations, a single value.
17		#'
18		#' @aliases GeneralData
19		#' @export
20		#'
21		.GeneralData <- setClass(
22		Class = "GeneralData",
23		slots = c(
24		ID = "integer",
25		cohort = "integer",
26		nObs = "integer"
27		),
28		prototype = prototype(
29		ID = integer(),
30		cohort = integer(),
31		nObs = 0L
32		),
33		contains = "CrmPackClass",
34		validity = v_general_data
35		)
36
37		## default constructor ----
38
39		#' @rdname GeneralData-class
40		#' @note Typically, end users will not use the `.DefaultDataGeneral()` function.
41		#' @export
42		.DefaultDataGeneral <- function() {
43	!	stop(paste0(
44	!	"Class DataGeneral cannot be instantiated directly. Please use one of its subclasses instead."
45		))
46		}
47
48		# Data ----
49
50		## class ----
51
52		#' `Data`
53		#'
54		#' @description `r lifecycle::badge("stable")`
55		#'
56		#' [`Data`] is a class for the data input.
57		#' It inherits from [`GeneralData`].
58		#'
59		#' @slot x (`numeric`)\cr the doses for the patients.
60		#' @slot y (`integer`)\cr the vector of toxicity events (0 or 1 integers).
61		#' @slot doseGrid (`numeric`)\cr the vector of all possible doses (sorted),
62		#' i.e. the dose grid.
63		#' @slot nGrid (`integer`)\cr number of gridpoints.
64		#' @slot xLevel (`integer`)\cr the levels for the doses the patients have been given,
65		#' w.r.t `doseGrid`.
66		#' @slot placebo (`logical`)\cr if `TRUE` the first dose level
67		#' in the `doseGrid`is considered as PLACEBO.
68		#'
69		#' @aliases Data
70		#' @export
71		#'
72		.Data <- setClass(
73		Class = "Data",
74		contains = "GeneralData",
75		slots = c(
76		x = "numeric",
77		y = "integer",
78		doseGrid = "numeric",
79		nGrid = "integer",
80		xLevel = "integer",
81		placebo = "logical"
82		),
83		prototype = prototype(
84		x = numeric(),
85		y = integer(),
86		doseGrid = numeric(),
87		nGrid = 0L,
88		xLevel = integer(),
89		placebo = FALSE
90		),
91		validity = v_data
92		)
93
94		## constructor ----
95
96		#' @rdname Data-class
97		#'
98		#' @details The `cohort` can be missing if and only if `placebo` is equal to
99		#' `FALSE`.
100		#'
101		#' @note `ID` and `cohort` can be missing. Then a message will be issued
102		#' and the variables will be filled with default IDs and best guesses cohort,
103		#' i.e. a sorted (in ascending order) sequence of values from `{1, 2, ...}`.
104		#'
105		#' @param x (`numeric`)\cr the doses for the patients.
106		#' @param y (`integer`)\cr the vector of toxicity events (0 or 1).
107		#' You can also supply `numeric` vectors, but these will then be converted to
108		#' `integer` internally.
109		#' @param ID (`integer`)\cr unique patient IDs.
110		#' You can also supply `numeric` vectors, but these will then be converted to
111		#' `integer` internally.
112		#' @param cohort (`integer`)\cr the cohort (non-negative sorted) indices.
113		#' You can also supply `numeric` vectors, but these will then be converted to
114		#' `integer` internally.
115		#' @param doseGrid (`numeric`)\cr all possible doses.
116		#' @param placebo (`flag`)\cr if `TRUE` the first dose level
117		#' in the `doseGrid` is considered as placebo.
118		#' @param ... not used.
119		#'
120		#' @export
121		#' @example examples/Data-class.R
122		#'
123		Data <- function(
124		x = numeric(),
125		y = integer(),
126		ID = integer(),
127		cohort = integer(),
128		doseGrid = numeric(),
129		placebo = FALSE,
130		...
131		) {
132	904x	assert_numeric(x)
133	904x	assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE)
134	904x	assert_integerish(ID, unique = TRUE, any.missing = FALSE)
135	904x	assert_integerish(cohort)
136	904x	if (length(x) > 0) {
137	657x	assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE, min.len = 1)
138		} else {
139	247x	assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
140		}
141	903x	assert_flag(placebo)
142
143	903x	doseGrid <- sort(doseGrid)
144	903x	assert_subset(x, doseGrid)
145
146	903x	if (length(ID) == 0 && length(x) > 0) {
147	1x	message("Used default patient IDs!")
148	1x	ID <- seq_along(x)
149		} else {
150	902x	assert_integerish(ID, unique = TRUE)
151		}
152
153	903x	if (!placebo && length(cohort) == 0 && length(x) > 0) {
154	1x	message("Used best guess cohort indices!")
155		# This is just assuming that consecutive patients
156		# in the data set are in the same cohort if they
157		# have the same dose. Note that this could be wrong,
158		# if two subsequent cohorts are at the same dose.
159	1x	cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
160		} else {
161	902x	assert_integerish(cohort)
162		}
163
164	903x	.Data(
165	903x	x = as.numeric(x),
166	903x	y = as.integer(y),
167	903x	ID = as.integer(ID),
168	903x	cohort = as.integer(cohort),
169	903x	doseGrid = as.numeric(doseGrid),
170	903x	nObs = length(x),
171	903x	nGrid = length(doseGrid),
172	903x	xLevel = match_within_tolerance(x, doseGrid),
173	903x	placebo = placebo
174		)
175		}
176
177		## default constructor ----
178
179		#' @rdname Data-class
180		#' @note Typically, end users will not use the `.DefaultData()` function.
181		#' @export
182		.DefaultData <- function() {
183	15x	Data(
184	15x	doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
185	15x	ID = 1L:3L,
186	15x	cohort = 1L:3L,
187	15x	x = c(1, 3, 5),
188	15x	y = rep(0L, 3)
189		)
190		}
191
192		# DataDual ----
193
194		## class ----
195
196		#' `DataDual`
197		#'
198		#' @description `r lifecycle::badge("stable")`
199		#'
200		#' [`DataDual`] is a class for the dual endpoint data.
201		#' It inherits from [`Data`] and it contains additional biomarker information.
202		#'
203		#' @slot w (`numeric`)\cr the continuous vector of biomarker values.
204		#'
205		#' @aliases DataDual
206		#' @export
207		#'
208		.DataDual <- setClass(
209		Class = "DataDual",
210		slots = c(w = "numeric"),
211		prototype = prototype(w = numeric()),
212		contains = "Data",
213		validity = v_data_dual
214		)
215
216		## constructor ----
217
218		#' @rdname DataDual-class
219		#'
220		#' @param w (`numeric`)\cr the continuous vector of biomarker values.
221		#' @param ... parameters passed to [Data()].
222		#'
223		#' @export
224		#' @example examples/Data-class-DataDual.R
225		#'
226		DataDual <- function(w = numeric(), ...) {
227	187x	d <- Data(...)
228	187x	.DataDual(d, w = w)
229		}
230
231
232		## default constructor ----
233
234		#' @rdname DataDual-class
235		#' @note Typically, end users will not use the `.DefaultDataDual()` function.
236		#' @export
237		.DefaultDataDual <- function() {
238	6x	set.seed(1230)
239	6x	DataDual(
240	6x	x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
241	6x	y = c(0, 0, 0, 0, 0, 0, 1, 0),
242	6x	w = rnorm(8),
243	6x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
244	6x	ID = 1L:8L,
245	6x	cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
246		)
247		}
248
249		# DataParts ----
250
251		## class ----
252
253		#' `DataParts`
254		#'
255		#' @description `r lifecycle::badge("stable")`
256		#'
257		#' [`DataParts`] is a class for the data with two study parts.
258		#' It inherits from [`Data`] and it contains additional information
259		#' on the two study parts.
260		#'
261		#' @slot part (`integer`)\cr which part does each of the patients belong to?
262		#' @slot nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
263		#' @slot part1Ladder (`numeric`)\cr what is the escalation ladder for
264		#' part 1? This shall be an ordered subset of the `doseGrid`.
265		#'
266		#' @aliases DataParts
267		#' @export
268		#'
269		.DataParts <- setClass(
270		Class = "DataParts",
271		slots = c(
272		part = "integer",
273		nextPart = "integer",
274		part1Ladder = "numeric"
275		),
276		prototype = prototype(
277		part = integer(),
278		nextPart = 1L,
279		part1Ladder = numeric()
280		),
281		contains = "Data",
282		validity = v_data_parts
283		)
284
285		## constructor ----
286
287		#' @rdname DataParts-class
288		#'
289		#' @param part (`integer`)\cr which part does each of the patients belong to?
290		#' @param nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
291		#' @param part1Ladder (`numeric`)\cr what is the escalation ladder for part 1?
292		#' This shall be an ordered subset of the `doseGrid`.
293		#' @param ... parameters passed to [Data()].
294		#'
295		#' @export
296		#' @example examples/Data-class-DataParts.R
297		#'
298		DataParts <- function(
299		part = integer(),
300		nextPart = 1L,
301		part1Ladder = numeric(),
302		...
303		) {
304	26x	d <- Data(...)
305	26x	.DataParts(
306	26x	d,
307	26x	part = part,
308	26x	nextPart = nextPart,
309	26x	part1Ladder = part1Ladder
310		)
311		}
312
313		## default constructor ----
314
315		#' @rdname DataParts-class
316		#' @note Typically, end users will not use the `.DefaultDataParts()` function.
317		#' @export
318		.DefaultDataParts <- function() {
319	5x	DataParts(
320	5x	x = c(0.1, 0.5, 1.5),
321	5x	y = c(0, 0, 0),
322	5x	ID = 1:3,
323	5x	cohort = 1:3,
324	5x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
325	5x	part = c(1L, 1L, 1L),
326	5x	nextPart = 1L,
327	5x	part1Ladder = c(0.1, 0.5, 1.5, 3, 6, 10)
328		)
329		}
330
331
332		# DataMixture ----
333
334		## class ----
335
336		#' `DataMixture`
337		#'
338		#' @description `r lifecycle::badge("stable")`
339		#'
340		#' [`DataMixture`] is a class for the data with mixture sharing.
341		#' It inherits from [`Data`] and it contains additional information
342		#' on the mixture sharing.
343		#'
344		#' @slot xshare (`numeric`)\cr the doses for the share patients.
345		#' @slot yshare (`integer`)\cr the vector of toxicity events (0 or 1)
346		#' for the share patients.
347		#' @slot nObsshare (`count`)\cr number of share patients.
348		#'
349		#' @aliases DataMixture
350		#' @export
351		#'
352		.DataMixture <- setClass(
353		Class = "DataMixture",
354		slots = c(
355		xshare = "numeric",
356		yshare = "integer",
357		nObsshare = "integer"
358		),
359		prototype = prototype(
360		xshare = numeric(),
361		yshare = integer(),
362		nObsshare = 0L
363		),
364		contains = "Data",
365		validity = v_data_mixture
366		)
367
368		## constructor ----
369
370		#' @rdname DataMixture-class
371		#'
372		#' @param xshare (`numeric`)\cr the doses for the share patients.
373		#' @param yshare (`integer`)\cr the vector of toxicity events (0 or 1)
374		#' for the share patients. You can also supply `numeric` vectors,
375		#' but these will then be converted to `integer` internally.
376		#' @param ... parameters passed to [Data()].
377		#'
378		#' @export
379		#' @example examples/Data-class-DataMixture.R
380		#'
381		DataMixture <- function(xshare = numeric(), yshare = integer(), ...) {
382	8x	d <- Data(...)
383	8x	assert_integerish(yshare)
384	8x	assert_numeric(xshare)
385	8x	.DataMixture(
386	8x	d,
387	8x	xshare = as.numeric(xshare),
388	8x	yshare = as.integer(yshare),
389	8x	nObsshare = length(xshare)
390		)
391		}
392
393		## default constructor ----
394
395		#' @rdname DataMixture-class
396		#' @note Typically, end users will not use the `.DefaultDataMixture()` function.
397		#' @export
398		.DefaultDataMixture <- function() {
399	6x	DataMixture(
400	6x	xshare = c(12, 14, 16, 18.0),
401	6x	yshare = c(0L, 1L, 1L, 1L),
402	6x	nObsshare = 4L,
403	6x	x = c(0.1, 0.5, 1.5),
404	6x	y = c(0, 0, 0),
405	6x	ID = 1L:3L,
406	6x	cohort = 1L:3L,
407	6x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2))
408		)
409		}
410
411
412		# DataDA ----
413
414		## class ----
415
416		#' `DataDA`
417		#'
418		#' @description `r lifecycle::badge("stable")`
419		#'
420		#' [`DataDA`] is a class for the time-to-DLT augmented data.
421		#' It inherits from [`Data`] and it contains additional DLT free survival times.
422		#'
423		#' @note `survival time` here refers to the time period for which the subject
424		#' did not experience any DLT, and is not referring to deaths.
425		#'
426		#' @slot u (`numeric`)\cr the continuous vector of DLT free survival times.
427		#' @slot t0 (`numeric`)\cr time of initial dosing for each patient.
428		#' Non-negative values sorted in ascending order.
429		#' @slot Tmax (`number`)\cr the DLT observation period.
430		#'
431		#' @aliases DataDA
432		#' @export
433		#'
434		.DataDA <- setClass(
435		Class = "DataDA",
436		slots = c(
437		u = "numeric",
438		t0 = "numeric",
439		Tmax = "numeric"
440		),
441		prototype = prototype(
442		u = numeric(),
443		t0 = numeric(),
444		Tmax = 0 + .Machine$double.xmin
445		),
446		contains = "Data",
447		validity = v_data_da
448		)
449
450		## constructor ----
451
452		#' @rdname DataDA-class
453		#'
454		#' @param u (`numeric`)\cr the continuous vector of DLT free survival times.
455		#' @param t0 (`numeric`)\cr time of initial dosing for each patient.
456		#' Non-negative values sorted in ascending order.
457		#' Default to vector of 0s of length equal to length of `u`.
458		#' @param Tmax (`number`)\cr the DLT observation period.
459		#' @param ... parameters passed to [Data()].
460		#'
461		#' @export
462		#' @example examples/Data-class-DataDA.R
463		#'
464		DataDA <- function(
465		u = numeric(),
466		t0 = numeric(length(u)),
467		Tmax = 0 + .Machine$double.xmin,
468		...
469		) {
470	26x	d <- Data(...)
471	26x	.DataDA(
472	26x	d,
473	26x	u = as.numeric(u),
474	26x	t0 = as.numeric(t0),
475	26x	Tmax = as.numeric(Tmax)
476		)
477		}
478
479		## default constructor ----
480
481		#' @rdname DataDA-class
482		#' @note Typically, end users will not use the `.DefaultDataDA()` function.
483		#' @export
484		.DefaultDataDA <- function() {
485	6x	DataDA(
486	6x	u = c(42, 30, 15, 5, 20, 25, 30, 60),
487	6x	t0 = c(0, 15, 30, 40, 55, 70, 75, 85),
488	6x	Tmax = 60,
489	6x	x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
490	6x	y = c(0, 0, 1, 1, 0, 0, 1, 0),
491	6x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
492	6x	ID = 1L:8L,
493	6x	cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
494		)
495		}
496
497		# DataOrdinal ----
498
499		## class ----
500
501		#' `DataOrdinal`
502		#'
503		#' @description `r lifecycle::badge("experimental")`
504		#'
505		#' [`DataOrdinal`] is a class for ordinal toxicity data.
506		#' It inherits from [`GeneralData`] and it describes toxicity responses on an
507		#' ordinal rather than binary scale.
508		#'
509		#' @note This class has been implemented as a sibling of the existing `Data` class
510		#' (rather than as a parent or child) to minimise the risk of unintended side
511		#' effects on existing classes and methods.
512		#'
513		#' The default setting for the `yCategories` slot replicates the behaviour
514		#' of the existing `Data` class.
515		#'
516		#' @aliases DataOrdinal
517		#' @export
518		.DataOrdinal <- setClass(
519		Class = "DataOrdinal",
520		contains = "GeneralData",
521		slots = c(
522		x = "numeric",
523		y = "integer",
524		doseGrid = "numeric",
525		nGrid = "integer",
526		xLevel = "integer",
527		yCategories = "integer",
528		placebo = "logical"
529		),
530		prototype = prototype(
531		x = numeric(),
532		y = integer(),
533		doseGrid = numeric(),
534		nGrid = 0L,
535		xLevel = integer(),
536		yCategories = c("No DLT" = 0L, "DLT" = 1L),
537		placebo = FALSE
538		),
539		validity = v_data_ordinal
540		)
541
542		## constructor ----
543
544		#' @rdname DataOrdinal-class
545		#' @param yCategories (named `integer`)\cr the names and codes for the
546		#' toxicity categories used in the data. Category labels are taken from the
547		#' names of the vector. The names of the vector must be unique and its values
548		#' must be sorted and take the values 0, 1, 2, ...
549		#' @inheritParams Data
550		#' @inherit Data details note params
551		#' @example examples/Data-class-DataOrdinal.R
552		#' @export
553		DataOrdinal <- function(
554		x = numeric(),
555		y = integer(),
556		ID = integer(),
557		cohort = integer(),
558		doseGrid = numeric(),
559		placebo = FALSE,
560		yCategories = c("No DLT" = 0L, "DLT" = 1L),
561		...
562		) {
563	69x	assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
564	69x	assert_integerish(
565	69x	yCategories,
566	69x	any.missing = FALSE,
567	69x	unique = TRUE,
568	69x	names = "unique",
569	69x	min.len = 2
570		)
571	69x	assert_flag(placebo)
572
573	69x	doseGrid <- as.numeric(sort(doseGrid))
574
575	69x	if (length(ID) == 0 && length(x) > 0) {
576	!	message("Used default patient IDs!")
577	!	ID <- seq_along(x)
578		} else {
579	69x	assert_integerish(ID, unique = TRUE)
580		}
581
582	69x	if (!placebo && length(cohort) == 0 && length(x) > 0) {
583	!	message("Used best guess cohort indices!")
584		# This is just assuming that consecutive patients
585		# in the data set are in the same cohort if they
586		# have the same dose. Note that this could be wrong,
587		# if two subsequent cohorts are at the same dose.
588	!	cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
589		} else {
590	69x	assert_integerish(cohort)
591		}
592
593	69x	.DataOrdinal(
594	69x	x = as.numeric(x),
595	69x	y = as.integer(y),
596	69x	ID = as.integer(ID),
597	69x	cohort = as.integer(cohort),
598	69x	doseGrid = doseGrid,
599	69x	nObs = length(x),
600	69x	nGrid = length(doseGrid),
601	69x	xLevel = match_within_tolerance(x = x, table = doseGrid),
602	69x	placebo = placebo,
603	69x	yCategories = yCategories
604		)
605		}
606
607
608		## default constructor ----
609
610		#' @rdname DataOrdinal-class
611		#' @note Typically, end users will not use the `.DefaultDataOrdinal()` function.
612		#' @export
613		.DefaultDataOrdinal <- function() {
614	22x	DataOrdinal(
615	22x	x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
616	22x	y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
617	22x	ID = 1L:10L,
618	22x	cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
619	22x	doseGrid = c(seq(from = 10, to = 100, by = 10)),
620	22x	yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
621	22x	placebo = FALSE
622		)
623		}
624
625		# DataGrouped ----
626
627		## class ----
628
629		#' `DataGrouped`
630		#'
631		#' @description `r lifecycle::badge("stable")`
632		#'
633		#' [`DataGrouped`] is a class for a two groups dose escalation data set,
634		#' comprised of a monotherapy (`mono`) and a combination therapy (`combo`)
635		#' arm. It inherits from [`Data`] and it contains the additional group information.
636		#'
637		#' @slot group (`factor`)\cr whether `mono` or `combo` was used.
638		#'
639		#' @aliases DataGrouped
640		#' @export
641		.DataGrouped <- setClass(
642		Class = "DataGrouped",
643		slots = c(
644		group = "factor"
645		),
646		prototype = prototype(
647		group = factor(levels = c("mono", "combo"))
648		),
649		contains = "Data",
650		validity = v_data_grouped
651		)
652
653		#' @rdname DataGrouped-class
654		#'
655		#' @param group (`factor` or `character`)\cr whether `mono` or `combo` was used.
656		#' If `character` then will be coerced to `factor` with the correct levels
657		#' internally.
658		#' @param ... parameters passed to [Data()].
659		#'
660		#' @export
661		#' @example examples/Data-class-DataGrouped.R
662		#'
663		DataGrouped <- function(group = character(), ...) {
664	81x	d <- Data(...)
665	81x	if (!is.factor(group)) {
666	81x	assert_character(group)
667	81x	assert_subset(group, choices = c("mono", "combo"))
668	81x	group <- factor(group, levels = c("mono", "combo"))
669		}
670	81x	.DataGrouped(
671	81x	d,
672	81x	group = group
673		)
674		}
675
676		## default constructor ----
677
678		#' @rdname DataGrouped-class
679		#' @note Typically, end users will not use the `.DefaultDataGrouped()` function.
680		#' @export
681		.DefaultDataGrouped <- function() {
682	7x	DataGrouped(
683	7x	group = c("mono", "mono", "combo"),
684	7x	x = c(1, 3, 5),
685	7x	y = c(0, 0, 0),
686	7x	ID = 1L:3L,
687	7x	cohort = 1L:3L,
688	7x	doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
689	7x	placebo = FALSE
690		)
691		}

1		# Integration with knitr ----
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' We provide additional utility functions to allow human-friendly rendition of
6		#' crmPack objects in Markdown and Quarto files. This file contains methods for
7		#' all design classes, not just those that are direct descendants of `Design`.
8		#'
9		#' @return a character string that represents the object in markdown.
10		#' @name knit_print
11		NULL
12
13		#' Internal Helper Functions for Validation of [`StartingDose`] Objects
14		#'
15		#' @description `r lifecycle::badge("experimental")`
16		#'
17		#' Validates that the `StartingDose` object contains valid `starting_dose`.
18		#'
19		#' @param object (`StartingDose`)\cr object to validate.
20		#' @return A `character` vector with the validation failure messages,
21		#' or `TRUE` in case validation passes.
22		#' @keywords internal
23		v_starting_dose <- function(object) {
24	!	v <- Validate()
25	!	v$check(
26	!	test_number(object@starting_dose, finite = TRUE, lower = 0),
27	!	"starting_dose must be a non-negative, finite number"
28		)
29	!	v$result()
30		}
31
32		# Helper class
33
34		#' `StartingDose`
35		#'
36		#' @description `r lifecycle::badge("experimental")`
37		#'
38		#' [`StartingDose`] is a simple wrapper class for the `startingDose` slot of all
39		#' design classes. It is used internally by `knit_print` methods
40		#'
41		#' @slot starting_dose (`numeric`)\cr the starting dose
42		#' @rdname StartingDose-class
43		#' @keywords internal
44		.StartingDose <- setClass(
45		Class = "StartingDose",
46		slots = c(
47		starting_dose = "numeric"
48		),
49		prototype = prototype(
50		starting_dose = 1
51		),
52		validity = v_starting_dose,
53		contains = "CrmPackClass"
54		)
55
56		## constructor ----
57
58		#' @rdname StartingDose-class
59		#' @param starting_dose (`positive_number`)\cr see slot definition.
60		StartingDose <- function(starting_dose) {
61	75x	new(
62	75x	"StartingDose",
63	75x	starting_dose = starting_dose
64		)
65		}
66
67		#' @rdname StartingDose-class
68		#' @note Typically, end users will not use the `.DefaultStartingDose()` function.
69		.DefaultStartingDose <- function() {
70	5x	StartingDose(starting_dose = 5)
71		}
72
73		# Helper functions ----
74
75		h_knit_print_design <- function(
76		x,
77		...,
78		level = 2L,
79		title = "Design",
80		default_sections = NA,
81		user_sections = NA,
82		ignore_slots = c(),
83		asis = TRUE
84		) {
85	83x	assert_flag(asis)
86		# Because subsections use level + 1 and 6 is the lowest markdown header level
87	65x	assert_int(level, lower = 1, upper = 5)
88	65x	assert_character(title, any.missing = FALSE, len = 1L)
89
90	65x	slots_to_process <- setdiff(slotNames(x), ignore_slots)
91
92	65x	args <- list(...)
93	65x	units <- ifelse("units" %in% names(args), paste0(" ", args[["units"]]), "")
94	65x	section_labels <- h_prepare_section_labels(
95	65x	x,
96	65x	default_sections,
97	65x	user_sections
98		)
99	65x	assert_subset(slots_to_process, names(section_labels))
100
101	65x	rv <- paste0(
102	65x	h_markdown_header(title, level = level),
103	65x	paste0(
104	65x	lapply(
105	65x	slots_to_process,
106	65x	function(nm) {
107	478x	tmp <- switch(
108	478x	nm,
109	478x	starting_dose = knit_print(
110	478x	StartingDose(x@starting_dose),
111	478x	asis = FALSE,
112	478x	level = level + 1L,
113		...
114		),
115	478x	startingDose = knit_print(
116	478x	StartingDose(x@startingDose),
117	478x	asis = FALSE,
118	478x	level = level + 1L,
119		...
120		),
121	478x	pl_cohort_size = ifelse(
122	478x	identical(slot(x, "pl_cohort_size"), CohortSizeConst(0)),
123	478x	"Placebo will not be administered in the trial.\n\n",
124	478x	knit_print(
125	478x	slot(x, "pl_cohort_size"),
126	478x	asis = FALSE,
127	478x	level = level + 1L,
128		...
129		)
130		),
131		{
132	361x	knit_print(slot(x, nm), asis = FALSE, level = level + 1L, ...)
133		}
134		)
135	478x	paste0(h_markdown_header(section_labels[nm], level + 1L), tmp)
136		}
137		),
138	65x	collapse = "\n\n"
139		),
140	65x	"\n\n"
141		)
142
143	65x	if (asis) {
144	27x	rv <- knitr::asis_output(rv)
145		}
146	65x	rv
147		}
148
149		#' @description A Helper Function to create Markdown Headers
150		#'
151		#' @param text (`character`) the header text
152		#' @param level (`positive_integer`) the level of the header. Must be between 1 and 6.
153		#' @return the Markdown header string: a newline, `#` repeated `level` times,
154		#' a space, `text` followed by two newlines.
155		#' @keywords internal
156		#' @noRd
157		h_markdown_header <- function(text, level = 2L) {
158	567x	assert_character(text, any.missing = FALSE, len = 1L, min.chars = 2L)
159	564x	assert_int(level, lower = 1, upper = 6)
160
161	561x	paste0(
162	561x	"\n",
163	561x	stringr::str_dup("#", level),
164		" ",
165	561x	text,
166	561x	"\n\n"
167		)
168		}
169
170		#' Modify a Set of Default Slot Labels With Custom Custom Labels
171		#'
172		#' x (`S4`)\cr the S4 object for which slot labels are required
173		#' default_labels (`character`)\cr a vector of slot labels whose names are a
174		#' superset of the slot names of `x`
175		#' user_labels (`character`)\cr a vector of slot labels whose names are a
176		#' superset of the slot names of `x`. Can be `NA`, in which case no updates
177		#' are made
178		#' @returns `default_labels` updated according to `user_labels`
179		#' @noRd
180		#' @keywords internal
181		h_prepare_section_labels <- function(x, default_labels, user_labels = NA) {
182	71x	assert_true(isS4(x))
183	71x	assert_character(default_labels, any.missing = FALSE)
184
185	71x	if (!any(is.na(user_labels))) {
186	9x	assert_character(user_labels, any.missing = FALSE)
187	9x	assert_subset(names(user_labels), slotNames(x))
188
189	9x	for (nm in names(user_labels)) {
190	7x	default_labels[nm] <- user_labels[nm]
191		}
192		}
193	71x	default_labels
194		}
195
196		# Methods ----
197
198		# StartingDose ----
199
200		#' @description `r lifecycle::badge("experimental")`
201		#' @rdname knit_print
202		#' @export
203		#' @method knit_print StartingDose
204		knit_print.StartingDose <- function(x, ..., asis = TRUE) {
205	73x	assert_flag(asis)
206
207	71x	args <- list(...)
208	71x	units <- ifelse("units" %in% names(args), paste0(" ", args[["units"]]), "")
209	71x	rv <- paste0(
210	71x	"The starting dose is ",
211	71x	paste0(x@starting_dose, units),
212	71x	".\n\n"
213		)
214
215	71x	if (asis) {
216	2x	rv <- knitr::asis_output(rv)
217		}
218	71x	rv
219		}
220
221		# RuleDesign ----
222
223		#' @description `r lifecycle::badge("experimental")`
224		#' @inheritParams knit_print.StoppingTargetProb
225		#' @param level (`positive_integer`) The level of the headings used to separate
226		#' slots. Must be between 1 and 6.
227		#' @param title (`character`) The text of the heading of the section describing
228		#' the design
229		#' @param sections (`character`) a named vector of length at least 4 defining
230		#' the headings used to define the sections corresponding to the design's slots.
231		#' The element names must match the Design's slot names.
232		#' @rdname knit_print
233		#' @export
234		#' @method knit_print RuleDesign
235		knit_print.RuleDesign <- function(
236		x,
237		...,
238		level = 2L,
239		title = "Design",
240		sections = NA,
241		asis = TRUE
242		) {
243	8x	h_knit_print_design(
244	8x	x,
245		...,
246	8x	level = 2L,
247	8x	title = "Design",
248	8x	default_sections = c(
249	8x	"nextBest" = "Dose recommendation",
250	8x	"cohort_size" = "Cohort size",
251	8x	"data" = "Observed data",
252	8x	"startingDose" = "Starting dose"
253		),
254	8x	user_sections = sections,
255	8x	asis = asis
256		)
257		}
258
259		# Design ----
260
261		#' @description `r lifecycle::badge("experimental")`
262		#' @inheritParams knit_print.RuleDesign
263		#' @rdname knit_print
264		#' @export
265		#' @method knit_print Design
266		knit_print.Design <- function(
267		x,
268		...,
269		level = 2L,
270		title = "Design",
271		sections = NA,
272		asis = TRUE
273		) {
274	22x	h_knit_print_design(
275	22x	x,
276		...,
277	22x	level = 2L,
278	22x	title = "Design",
279	22x	default_sections = c(
280	22x	"nextBest" = "Dose recommendation",
281	22x	"cohort_size" = "Cohort size",
282	22x	"data" = "Observed data",
283	22x	"startingDose" = "Starting dose",
284	22x	"increments" = "Escalation rule",
285	22x	"stopping" = "Stopping rule",
286	22x	"model" = "Dose toxicity model",
287	22x	"pl_cohort_size" = "Use of placebo"
288		),
289	22x	user_sections = sections,
290	22x	asis = asis
291		)
292		}
293
294		# DualDesign ----
295
296		#' @description `r lifecycle::badge("experimental")`
297		#' @inheritParams knit_print.RuleDesign
298		#' @rdname knit_print
299		#' @export
300		#' @method knit_print DualDesign
301		knit_print.DualDesign <- function(
302		x,
303		...,
304		level = 2L,
305		title = "Design",
306		sections = NA,
307		asis = TRUE
308		) {
309	8x	assert_flag(asis)
310	6x	assert_character(title, len = 1, any.missing = FALSE)
311	6x	assert_integer(level, len = 1, lower = 1, upper = 6)
312
313	6x	args <- list(...)
314	6x	bLabel <- ifelse(
315	6x	"biomarker_label" %in% names(args),
316	6x	args[["biomarker_label"]],
317	6x	"biomarker"
318		)
319	6x	tLabel <- ifelse(
320	6x	"tox_label" %in% names(args),
321	6x	args[["tox_label"]],
322	6x	"toxicity"
323		)
324
325	6x	if (is.na(sections)) {
326	6x	sections <- c(
327	6x	"model" = paste0("Dose-", tLabel, " and dose-", bLabel, " models")
328		)
329		} else {
330	!	if (!("model" %in% names(sections))) {
331	!	sections["model"] <- paste0(
332	!	"Dose-",
333	!	tLabel,
334	!	" and dose-",
335	!	bLabel,
336	!	" models"
337		)
338		}
339		}
340
341	6x	knit_print.Design(
342	6x	x,
343	6x	level = level,
344	6x	title = title,
345	6x	sections = sections,
346	6x	asis = asis,
347		...
348		)
349		}
350
351		# DADesign ----
352
353		#' @description `r lifecycle::badge("experimental")`
354		#' @inheritParams knit_print.RuleDesign
355		#' @rdname knit_print
356		#' @export
357		#' @method knit_print DADesign
358		knit_print.DADesign <- function(
359		x,
360		...,
361		level = 2L,
362		title = "Design",
363		sections = NA,
364		asis = TRUE
365		) {
366	8x	h_knit_print_design(
367	8x	x,
368		...,
369	8x	level = 2L,
370	8x	title = "Design",
371	8x	default_sections = c(
372	8x	"nextBest" = "Dose recommendation",
373	8x	"cohort_size" = "Cohort size",
374	8x	"data" = "Observed data",
375	8x	"startingDose" = "Starting dose",
376	8x	"increments" = "Escalation rule",
377	8x	"stopping" = "Stopping rule",
378	8x	"model" = "Dose toxicity model",
379	8x	"pl_cohort_size" = "Use of placebo",
380	8x	"safetyWindow" = "Safety window"
381		),
382	8x	user_sections = sections,
383	8x	asis = asis
384		)
385		}
386
387		# TDDesign ----
388
389		#' @description `r lifecycle::badge("experimental")`
390		#' @inheritParams knit_print.RuleDesign
391		#' @rdname knit_print
392		#' @export
393		#' @method knit_print TDDesign
394		knit_print.TDDesign <- function(
395		x,
396		...,
397		level = 2L,
398		title = "Design",
399		sections = NA,
400		asis = TRUE
401		) {
402	8x	knit_print.Design(
403	8x	x,
404	8x	level = level,
405	8x	title = title,
406	8x	sections = sections,
407	8x	asis = asis,
408		...
409		)
410		}
411
412		# DualResponsesDesign ----
413
414		#' @description `r lifecycle::badge("experimental")`
415		#' @inheritParams knit_print.RuleDesign
416		#' @rdname knit_print
417		#' @export
418		#' @method knit_print DualResponsesDesign
419		knit_print.DualResponsesDesign <- function(
420		x,
421		...,
422		level = 2L,
423		title = "Design",
424		sections = NA,
425		asis = TRUE
426		) {
427		knit_print.Design(
428		x,
429		level = level,
430		title = title,
431		sections = sections,
432		asis = asis,
433		...
434		)
435		}
436
437		# DesignOrdinal ----
438
439		#' @description `r lifecycle::badge("experimental")`
440		#' @inheritParams knit_print.RuleDesign
441		#' @rdname knit_print
442		#' @export
443		#' @method knit_print DesignOrdinal
444		knit_print.DesignOrdinal <- function(
445		x,
446		...,
447		level = 2L,
448		title = "Design",
449		sections = NA,
450		asis = TRUE
451		) {
452	6x	h_knit_print_design(
453	6x	x,
454		...,
455	6x	level = 2L,
456	6x	title = "Design",
457	6x	default_sections = c(
458	6x	"next_best" = "Dose recommendation",
459	6x	"cohort_size" = "Cohort size",
460	6x	"data" = "Observed data",
461	6x	"starting_dose" = "Starting dose",
462	6x	"increments" = "Escalation rule",
463	6x	"stopping" = "Stopping rule",
464	6x	"model" = "Dose toxicity model",
465	6x	"pl_cohort_size" = "Use of placebo"
466		),
467	6x	user_sections = sections,
468	6x	asis = asis
469		)
470		}
471
472		# DesignGrouped ----
473
474		# Needs special handling because of the empty models and nested rules in the
475		# mono and combo slots and because of the many slots that are of built-in types
476		# rather than being of crmPack-specific types
477
478		#' @description `r lifecycle::badge("experimental")`
479		#' @inheritParams knit_print.RuleDesign
480		#' @rdname knit_print
481		#' @export
482		#' @method knit_print DesignGrouped
483		knit_print.DesignGrouped <- function(
484		x,
485		...,
486		level = 2L,
487		title = "Design",
488		sections = c(
489		"model" = "Dose toxicity model",
490		"mono" = "Monotherapy rules",
491		"combo" = "Combination therapy rules",
492		"other" = "Other details"
493		),
494		asis = TRUE
495		) {
496	6x	assert_flag(asis)
497	4x	assert_character(title, len = 1, any.missing = FALSE)
498	4x	assert_integer(level, len = 1, lower = 1, upper = 6)
499
500	4x	rv <- paste0(
501	4x	h_markdown_header(sections["model"], level = level),
502	4x	knit_print(x@model, asis = FALSE, ...),
503	4x	h_markdown_header(sections["mono"], level = level),
504	4x	h_knit_print_design(
505	4x	x@mono,
506	4x	asis = FALSE,
507	4x	level = level + 1L,
508	4x	ignore_slots = c("model"),
509	4x	default_sections = c(
510	4x	"nextBest" = "Dose recommendation",
511	4x	"cohort_size" = "Cohort size",
512	4x	"data" = "Observed monotherapy data",
513	4x	"startingDose" = "Starting dose",
514	4x	"increments" = "Escalation rule",
515	4x	"stopping" = "Stopping rule",
516	4x	"pl_cohort_size" = "Use of placebo"
517		),
518	4x	sections = sections[["mono"]],
519		...
520		),
521	4x	h_markdown_header(sections["combo"], level = level),
522	4x	h_knit_print_design(
523	4x	x@combo,
524	4x	asis = FALSE,
525	4x	level = level + 1L,
526	4x	ignore_slots = "model",
527	4x	default_sections = c(
528	4x	"nextBest" = "Dose recommendation",
529	4x	"cohort_size" = "Cohort size",
530	4x	"data" = "Observed combination therapy data",
531	4x	"startingDose" = "Starting dose",
532	4x	"increments" = "Escalation rule",
533	4x	"stopping" = "Stopping rule",
534	4x	"pl_cohort_size" = "Use of placebo"
535		),
536	4x	sections = sections[["combo"]],
537		...
538		),
539	4x	h_markdown_header(sections["other"], level = level),
540	4x	ifelse(
541	4x	x@first_cohort_mono_only,
542	4x	paste0(
543	4x	"No combination dosing may occur until the results of at least one ",
544	4x	"monotherapy cohort are available.\n\n"
545		),
546	4x	"Simultaneous combination and monotherapy dosing is permitted from the outset.\n\n"
547		),
548	4x	ifelse(
549	4x	x@same_dose_for_start,
550	4x	paste0(
551	4x	"When monotherapy and combination therapy are used in the same cohort ",
552	4x	"for the first time, the same dose must be used for both regimens.\n\n"
553		),
554	4x	paste0(
555	4x	"When monotherapy and combination therapy are used in the same cohort ",
556	4x	"for the first time, the use of a different dose in each regimen is permitted.\n\n"
557		)
558		),
559	4x	ifelse(
560	4x	x@same_dose_for_all,
561	4x	paste0(
562	4x	"Whenever monotherapy and combination therapy are used in the same cohort, ",
563	4x	"the same dose must be used for both regimens.\n\n"
564		),
565	4x	paste0(
566	4x	"Whenever monotherapy and combination therapy are used in the same cohort, ",
567	4x	"the use of a different dose in each regimen is permitted.\n\n"
568		)
569		)
570		)
571
572	4x	if (asis) {
573	2x	rv <- knitr::asis_output(rv)
574		}
575	4x	rv
576		}
577
578		# TDsamplesDesign ----
579
580		#' @description `r lifecycle::badge("experimental")`
581		#' @inheritParams knit_print.RuleDesign
582		#' @rdname knit_print
583		#' @export
584		#' @method knit_print TDsamplesDesign
585		knit_print.TDsamplesDesign <- function(
586		x,
587		...,
588		level = 2L,
589		title = "Design",
590		sections = NA,
591		asis = TRUE
592		) {
593	6x	h_knit_print_design(
594	6x	x,
595		...,
596	6x	level = level,
597	6x	title = title,
598	6x	default_sections = c(
599	6x	"nextBest" = "Dose recommendation",
600	6x	"cohort_size" = "Cohort size",
601	6x	"data" = "Observed data",
602	6x	"startingDose" = "Starting dose",
603	6x	"model" = "Dose toxicity model",
604	6x	"stopping" = "Stopping rule",
605	6x	"increments" = "Escalation rule",
606	6x	"pl_cohort_size" = "Use of placebo"
607		),
608	6x	user_sections = sections,
609	6x	asis = asis
610		)
611		}
612
613		# DualResponsesDesign ----
614
615		#' @description `r lifecycle::badge("experimental")`
616		#' @inheritParams knit_print.RuleDesign
617		#' @rdname knit_print
618		#' @export
619		#' @method knit_print DualResponsesDesign
620		knit_print.DualResponsesDesign <- function(
621		x,
622		...,
623		level = 2L,
624		title = "Design",
625		sections = NA,
626		asis = TRUE
627		) {
628	8x	h_knit_print_design(
629	8x	x,
630		...,
631	8x	level = level,
632	8x	title = title,
633	8x	default_sections = c(
634	8x	"nextBest" = "Dose recommendation",
635	8x	"cohort_size" = "Cohort size",
636	8x	"data" = "Observed data",
637	8x	"startingDose" = "Starting dose",
638	8x	"increments" = "Escalation rule",
639	8x	"stopping" = "Stopping rule",
640	8x	"model" = "Dose-toxicity model",
641	8x	"eff_model" = "Dose-efficacy model",
642	8x	"pl_cohort_size" = "Use of placebo"
643		),
644	8x	ignore_sections = c("model", "eff_model"),
645	8x	sections = sections,
646	8x	asis = asis
647		)
648		}
649
650		# DualResponsesSamplesDesign ----
651
652		#' @description `r lifecycle::badge("experimental")`
653		#' @inheritParams knit_print.RuleDesign
654		#' @rdname knit_print
655		#' @export
656		#' @method knit_print DualResponsesSamplesDesign
657		knit_print.DualResponsesSamplesDesign <- function(
658		x,
659		...,
660		level = 2L,
661		title = "Design",
662		sections = NA,
663		asis = TRUE
664		) {
665	8x	h_knit_print_design(
666	8x	x,
667		...,
668	8x	level = level,
669	8x	title = title,
670	8x	default_sections = c(
671	8x	"nextBest" = "Dose recommendation",
672	8x	"cohort_size" = "Cohort size",
673	8x	"data" = "Observed data",
674	8x	"startingDose" = "Starting dose",
675	8x	"increments" = "Escalation rule",
676	8x	"stopping" = "Stopping rule",
677	8x	"model" = "Dose-toxicity model",
678	8x	"eff_model" = "Dose-efficacy model",
679	8x	"pl_cohort_size" = "Use of placebo"
680		),
681	8x	ignore_sections = c("model", "eff_model"),
682	8x	sections = sections,
683	8x	asis = asis
684		)
685		}
686
687		# RuleDesignOrdinal ----
688
689		#' @description `r lifecycle::badge("experimental")`
690		#' @inheritParams knit_print.RuleDesign
691		#' @rdname knit_print
692		#' @export
693		#' @method knit_print RuleDesignOrdinal
694		knit_print.RuleDesignOrdinal <- function(
695		x,
696		...,
697		level = 2L,
698		title = "Design",
699		sections = NA,
700		asis = TRUE
701		) {
702	9x	h_knit_print_design(
703	9x	x,
704		...,
705	9x	level = 2L,
706	9x	title = "Design",
707	9x	default_sections = c(
708	9x	"next_best" = "Dose recommendation",
709	9x	"cohort_size" = "Cohort size",
710	9x	"data" = "Observed data",
711	9x	"starting_dose" = "Starting dose"
712		),
713	9x	user_sections = sections,
714	9x	asis = asis
715		)
716		}

1		#' Internal Helper Functions for Validation of Model Parameters Objects
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' These functions are only used internally to validate the format of an object
6		#' with model parameters or inherited classes and therefore not exported.
7		#'
8		#' @name v_model_params
9		#' @return A `character` vector with the validation failure messages,
10		#' or `TRUE` in case validation passes.
11		NULL
12
13		#' @describeIn v_model_params a helper function that validates multivariate normal
14		#' parameters.
15		#' @param object (`ModelParamsNormal`)\cr multivariate normal parameters object
16		#' to validate.
17		v_model_params_normal <- function(object) {
18	9x	v <- Validate()
19
20	9x	v$check(
21	9x	test_numeric(x = object@mean, min.len = 2L, any.missing = FALSE),
22	9x	"mean must have length of at least 2 and no missing values are allowed"
23		)
24	9x	is_cov_valid <- h_is_positive_definite(object@cov, length(object@mean))
25	9x	v$check(
26	9x	is_cov_valid,
27	9x	"cov must be positive-definite matrix without any missing values"
28		)
29	9x	is_prec_valid <- h_is_positive_definite(object@prec, length(object@mean))
30	9x	v$check(
31	9x	is_prec_valid,
32	9x	"prec must be positive-definite matrix without any missing values"
33		)
34	9x	if (is_cov_valid && is_prec_valid) {
35	5x	v$check(
36	5x	all.equal(
37	5x	object@cov %*% object@prec,
38	5x	diag(1, length(object@mean)),
39	5x	check.attributes = FALSE
40		) ==
41	5x	TRUE,
42	5x	"prec must be inverse of cov"
43		)
44		}
45	9x	v$result()
46		}

1		# StoppingOrdinal ----
2
3		#' @description `r lifecycle::badge("experimental")`
4		#' @inheritParams knit_print.StoppingTargetProb
5		#' @rdname knit_print
6		#' @export
7		#' @method knit_print StoppingOrdinal
8		knit_print.StoppingOrdinal <- function(
9		x,
10		...,
11		asis = TRUE
12		) {
13	12x	assert_flag(asis)
14
15	10x	rv <- paste0(
16	10x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
17	10x	"Based on a toxicity grade of ",
18	10x	x@grade,
19		": ",
20	10x	paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n")
21		)
22
23	10x	if (asis) {
24	2x	rv <- knitr::asis_output(rv)
25		}
26	10x	rv
27		}
28
29		# StoppingMaxGainCIRatio ----
30
31		#' @description `r lifecycle::badge("experimental")`
32		#' @inheritParams knit_print.StoppingTargetProb
33		#' @rdname knit_print
34		#' @export
35		#' @method knit_print StoppingMaxGainCIRatio
36		knit_print.StoppingMaxGainCIRatio <- function(
37		x,
38		...,
39		asis = TRUE
40		) {
41	8x	assert_flag(asis)
42
43	6x	rv <- paste0(
44	6x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
45	6x	"If the ratio of the upper to the lower limit of the posterior 95% credible ",
46	6x	"interval for the probability of toxicity at the target dose (the smaller ",
47	6x	"of the MTD for ",
48	6x	100 * x@prob_target,
49	6x	"% target and GStar) is less than or equal to ",
50	6x	x@target_ratio,
51	6x	".\n\n"
52		)
53
54	6x	if (asis) {
55	2x	rv <- knitr::asis_output(rv)
56		}
57	6x	rv
58		}
59
60		# StoppingList ----
61
62		#' @description `r lifecycle::badge("experimental")`
63		#' @inheritParams knit_print.StoppingTargetProb
64		#' @param preamble (`character`)\cr the text that introduces the list of rules
65		#' @param indent (`integer`)\cr the indent level of the current stopping rule
66		#' list. Spaces with length `indent * 4` will be prepended to the beginning of
67		#' the rendered stopping rule list.
68		#' @rdname knit_print
69		#' @export
70		#' @method knit_print StoppingList
71		knit_print.StoppingList <- function(
72		x,
73		...,
74		preamble,
75		indent = 0L,
76		asis = TRUE
77		) {
78	63x	assert_flag(asis)
79	57x	assert_integer(indent, lower = 0)
80
81	57x	if (missing(preamble)) {
82	9x	case_string <- switch(
83	9x	as.character(length(x@stop_list)),
84	9x	`1` = "rule ",
85	9x	"rules "
86		)
87	9x	preamble <- paste0(
88	9x	"If the result of applying the summary function to the following ",
89	9x	case_string,
90	9x	"is `TRUE`:\n"
91		)
92		} else {
93	48x	assert_character(preamble, len = 1, any.missing = FALSE)
94		}
95
96	57x	rules_list <- paste0(
97	57x	lapply(
98	57x	x@stop_list,
99	57x	function(z, indent) {
100	131x	paste0(
101	131x	strrep(" ", indent * 4),
102		"- ",
103	131x	knit_print(z, asis = FALSE, indent = indent + 1L, ...)
104		)
105		},
106	57x	indent = indent
107		),
108	57x	collapse = "\n"
109		)
110	57x	rv <- paste0(
111	57x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
112	57x	preamble,
113	57x	"\n",
114	57x	rules_list,
115	57x	"\n\n"
116		)
117
118	57x	if (asis) {
119	6x	rv <- knitr::asis_output(rv)
120		}
121	57x	rv
122		}
123
124		# StoppingAny ----
125
126		#' @description `r lifecycle::badge("experimental")`
127		#' @inheritParams knit_print.StoppingList
128		#' @rdname knit_print
129		#' @export
130		#' @method knit_print StoppingAny
131		knit_print.StoppingAny <- function(
132		x,
133		...,
134		preamble,
135		asis = TRUE
136		) {
137	32x	if (missing(preamble)) {
138	32x	case_string <- switch(
139	32x	as.character(length(x@stop_list)),
140	32x	`1` = c("this ", "rule is "),
141	32x	`2` = c("either of the ", "rules are "),
142	32x	c("any of the ", "rules are ") # this works as default case
143		)
144	32x	preamble <- paste0(
145	32x	"If ",
146	32x	case_string[1],
147	32x	"following ",
148	32x	case_string[2],
149	32x	"`TRUE`:\n"
150		)
151		}
152	32x	knit_print.StoppingList(x, ..., preamble = preamble, asis = asis)
153		}
154
155		#' @description `r lifecycle::badge("experimental")`
156		#' @inheritParams knit_print.StoppingList
157		#' @rdname knit_print
158		#' @export
159		#' @method knit_print StoppingAll
160		knit_print.StoppingAll <- function(
161		x,
162		...,
163		preamble,
164		asis = TRUE
165		) {
166	20x	if (missing(preamble)) {
167	20x	case_string <- switch(
168	20x	as.character(length(x@stop_list)),
169	20x	`1` = c("this ", "rule is "),
170	20x	`2` = c("both of the ", "rules are "),
171	20x	c("all of the ", "rules are ") # this works as default case
172		)
173	20x	preamble <- paste0(
174	20x	"If ",
175	20x	case_string[1],
176	20x	"following ",
177	20x	case_string[2],
178	20x	"`TRUE`:\n"
179		)
180		}
181	20x	knit_print.StoppingList(x, ..., preamble = preamble, asis = asis)
182		}
183
184		# StoppingTDCIRatio ----
185
186		#' @description `r lifecycle::badge("experimental")`
187		#' @inheritParams knit_print.StoppingTargetProb
188		#' @rdname knit_print
189		#' @export
190		#' @method knit_print StoppingTDCIRatio
191		knit_print.StoppingTDCIRatio <- function(
192		x,
193		...,
194		dose_label = "the next best dose",
195		tox_label = "toxicity",
196		fmt_string = paste0(
197		"%sIf, at %s, the ratio of the upper to the lower limit of the posterior ",
198		"95%% credible interval for %s (targetting %2.0f%%) is less than or equal to "
199		),
200		asis = TRUE
201		) {
202	8x	assert_flag(asis)
203	6x	assert_character(fmt_string, len = 1, any.missing = FALSE)
204	6x	assert_character(tox_label, len = 1, any.missing = FALSE)
205	6x	assert_character(dose_label, len = 1, any.missing = FALSE)
206
207	6x	rv <- paste0(
208	6x	sprintf(
209	6x	fmt_string,
210	6x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
211	6x	dose_label,
212	6x	tox_label,
213	6x	100 * x@prob_target
214		),
215	6x	x@target_ratio,
216	6x	".\n\n"
217		)
218
219	6x	if (asis) {
220	2x	rv <- knitr::asis_output(rv)
221		}
222	6x	rv
223		}
224
225		# StoppingTargetBiomarker ----
226
227		#' @description `r lifecycle::badge("experimental")`
228		#' @inheritParams knit_print.StoppingTargetProb
229		#' @param biomarker_label (`character`)\cr the term used to describe the biomarker
230		#' @rdname knit_print
231		#' @export
232		#' @method knit_print StoppingTargetBiomarker
233		knit_print.StoppingTargetBiomarker <- function(
234		x,
235		...,
236		dose_label = "the next best dose",
237		biomarker_label = "the target biomarker",
238		fmt_string = paste0(
239		"%sIf, at %s, the posterior probability that %s is in the range ",
240		"(%.2f, %.2f)%s is %.0f%% or more.\n\n"
241		),
242		asis = TRUE
243		) {
244	14x	assert_flag(asis)
245	12x	assert_character(fmt_string, len = 1, any.missing = FALSE)
246	12x	assert_character(biomarker_label, len = 1, any.missing = FALSE)
247
248	12x	rv <- sprintf(
249	12x	fmt_string,
250	12x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
251	12x	dose_label,
252	12x	biomarker_label,
253	12x	x@target[1],
254	12x	x@target[2],
255	12x	ifelse(
256	12x	x@is_relative,
257	12x	paste0(", relative to the maximum value of ", biomarker_label, ","),
258		""
259		),
260	12x	100 * x@prob
261		)
262
263	12x	if (asis) {
264	2x	rv <- knitr::asis_output(rv)
265		}
266	12x	rv
267		}
268
269		# StoppingLowestDoseHSRBeta ----
270
271		#' @description `r lifecycle::badge("experimental")`
272		#' @inheritParams knit_print.StoppingTargetProb
273		#' @rdname knit_print
274		#' @export
275		#' @method knit_print StoppingLowestDoseHSRBeta
276		knit_print.StoppingLowestDoseHSRBeta <- function(
277		x,
278		...,
279		tox_label = "toxicity",
280		fmt_string = paste0(
281		"%sIf, using a Hard Stopping Rule with a prior of Beta(%.0f, %.0f), the ",
282		"lowest dose in the dose grid has a posterior probability of %s of ",
283		"%.0f%% or more.\n\n"
284		),
285		asis = TRUE
286		) {
287	8x	assert_flag(asis)
288	6x	assert_character(fmt_string, len = 1, any.missing = FALSE)
289
290	6x	rv <- sprintf(
291	6x	fmt_string,
292	6x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
293	6x	x@a,
294	6x	x@b,
295	6x	tox_label,
296	6x	100 * x@prob
297		)
298
299	6x	if (asis) {
300	2x	rv <- knitr::asis_output(rv)
301		}
302	6x	rv
303		}
304
305		# StoppingMTDCV ----
306
307		#' @description `r lifecycle::badge("experimental")`
308		#' @inheritParams knit_print.StoppingTargetProb
309		#' @rdname knit_print
310		#' @export
311		#' @method knit_print StoppingMTDCV
312		knit_print.StoppingMTDCV <- function(
313		x,
314		...,
315		fmt_string = paste0(
316		"%sIf the posterior estimate of the robust coefficient of variation of ",
317		"the MTD (targetting %2.0f%%), is than or equal to %.0f%%.\n\n"
318		),
319		asis = TRUE
320		) {
321	8x	assert_flag(asis)
322	6x	assert_character(fmt_string, len = 1, any.missing = FALSE)
323
324	6x	rv <- sprintf(
325	6x	fmt_string,
326	6x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
327	6x	100 * x@target,
328	6x	100 * x@thresh_cv
329		)
330
331	6x	if (asis) {
332	2x	rv <- knitr::asis_output(rv)
333		}
334	6x	rv
335		}
336
337		# StoppingMTDdistribution ----
338
339		#' @description `r lifecycle::badge("experimental")`
340		#' @inheritParams knit_print.StoppingTargetProb
341		#' @rdname knit_print
342		#' @export
343		#' @method knit_print StoppingMTDdistribution
344		knit_print.StoppingMTDdistribution <- function(
345		x,
346		...,
347		fmt_string = "%sIf the mean posterior probability of %s at %.0f%% of %s is at least %4.2f.\n\n",
348		dose_label = "the next best dose",
349		tox_label = "toxicity",
350		asis = TRUE
351		) {
352	8x	assert_flag(asis)
353	6x	assert_character(dose_label, len = 1, any.missing = FALSE)
354	6x	assert_character(tox_label, len = 1, any.missing = FALSE)
355	6x	assert_character(fmt_string, len = 1, any.missing = FALSE)
356
357	6x	rv <- sprintf(
358	6x	fmt_string,
359	6x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
360	6x	tox_label,
361	6x	100 * x@thresh,
362	6x	dose_label,
363	6x	x@prob
364		)
365
366	6x	if (asis) {
367	2x	rv <- knitr::asis_output(rv)
368		}
369	6x	rv
370		}
371
372		# StoppingHighestDose ----
373
374		#' @description `r lifecycle::badge("experimental")`
375		#' @param asis (`flag`)\cr Not used at present
376		#' @rdname knit_print
377		#' @export
378		#' @method knit_print StoppingHighestDose
379		knit_print.StoppingHighestDose <- function(
380		x,
381		...,
382		dose_label = "the highest dose in the dose grid",
383		asis = TRUE
384		) {
385	8x	rv <- paste0(
386	8x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
387	8x	"If the next best dose is ",
388	8x	dose_label,
389	8x	".\n\n"
390		)
391
392	8x	if (asis) {
393	2x	rv <- knitr::asis_output(rv)
394		}
395	6x	rv
396		}
397
398		# StoppingSpecificDose ----
399
400		#' @description `r lifecycle::badge("experimental")`
401		#' @param asis (`flag`)\cr Not used at present
402		#' @inheritParams knit_print.StoppingTargetProb
403		#' @rdname knit_print
404		#' @export
405		#' @method knit_print StoppingSpecificDose
406		knit_print.StoppingSpecificDose <- function(
407		x,
408		...,
409		dose_label = as.character(x@dose),
410		asis = TRUE
411		) {
412	8x	x@rule@report_label <- x@report_label
413	8x	knit_print(
414	8x	x@rule,
415		...,
416	8x	dose_label = dose_label,
417	8x	asis = asis
418		)
419		}
420
421		# StoppingTargetProb ----
422
423		#' @description `r lifecycle::badge("experimental")`
424		#' @param asis (`flag`)\cr Not used at present
425		#' @param fmt_string (`character`)\cr the character string that defines the format
426		#' of the output
427		#' @param dose_label (`character`)\cr the term used to describe the target dose
428		#' @param tox_label (`character`)\cr the term used to describe toxicity
429		#' @rdname knit_print
430		#' @export
431		#' @method knit_print StoppingTargetProb
432		knit_print.StoppingTargetProb <- function(
433		x,
434		...,
435		fmt_string = paste0(
436		"%sIf the probability of %s at %s is in the range [%4.2f, %4.2f] ",
437		"is at least %4.2f.\n\n"
438		),
439		dose_label = "the next best dose",
440		tox_label = "toxicity",
441		asis = TRUE
442		) {
443	60x	assert_flag(asis)
444	56x	assert_character(dose_label, len = 1, any.missing = FALSE)
445	56x	assert_character(tox_label, len = 1, any.missing = FALSE)
446	56x	assert_character(fmt_string, len = 1, any.missing = FALSE)
447
448	56x	rv <- sprintf(
449	56x	fmt_string,
450	56x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
451	56x	tox_label,
452	56x	dose_label,
453	56x	x@target[1],
454	56x	x@target[2],
455	56x	x@prob
456		)
457
458	56x	if (asis) {
459	6x	rv <- knitr::asis_output(rv)
460		}
461	56x	rv
462		}
463
464		# StoppingMinCohorts ----
465
466		#' @description `r lifecycle::badge("experimental")`
467		#' @param asis (`flag`)\cr Not used at present
468		#' @rdname knit_print
469		#' @export
470		#' @method knit_print StoppingMinCohorts
471		knit_print.StoppingMinCohorts <- function(
472		x,
473		...,
474		asis = TRUE
475		) {
476	43x	assert_flag(asis)
477
478	41x	rv <- paste0(
479	41x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
480	41x	"If ",
481	41x	x@nCohorts,
482	41x	" or more cohorts have been treated.\n\n"
483		)
484	41x	if (asis) {
485	2x	rv <- knitr::asis_output(rv)
486		}
487	41x	rv
488		}
489
490		# StoppingMinPatients ----
491
492		#' @description `r lifecycle::badge("experimental")`
493		#' @param label (`character`)\cr the term used to label participants
494		#' @param asis (`flag`)\cr Not used at present
495		#' @rdname knit_print
496		#' @export
497		#' @method knit_print StoppingMinPatients
498		knit_print.StoppingMinPatients <- function(
499		x,
500		...,
501		label = "participant",
502		asis = TRUE
503		) {
504	80x	assert_flag(asis)
505	78x	label <- h_prepare_labels(label)
506
507	78x	rv <- paste0(
508	78x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
509	78x	"If ",
510	78x	x@nPatients,
511	78x	paste0(" or more ", label[2], " have been treated."),
512	78x	"\n\n"
513		)
514	78x	if (asis) {
515	2x	rv <- knitr::asis_output(rv)
516		}
517	78x	rv
518		}
519
520		# StoppingPatientsNearDose ----
521
522		#' @description `r lifecycle::badge("experimental")`
523		#' @param label (`character`)\cr the term used to label participants
524		#' @inheritParams knit_print.StoppingTargetProb
525		#' @param asis (`flag`)\cr Not used at present
526		#' @rdname knit_print
527		#' @export
528		#' @method knit_print StoppingPatientsNearDose
529		knit_print.StoppingPatientsNearDose <- function(
530		x,
531		...,
532		dose_label = "the next best dose",
533		label = "participants",
534		asis = TRUE
535		) {
536	8x	assert_flag(asis)
537	6x	assert_character(label, len = 1, any.missing = FALSE)
538	6x	assert_character(dose_label, len = 1, any.missing = FALSE)
539
540	6x	rv <- paste0(
541	6x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
542	6x	"If ",
543	6x	x@nPatients,
544	6x	paste0(" or more ", label, " have been treated "),
545	6x	ifelse(
546	6x	x@percentage == 0,
547	6x	"at ",
548	6x	paste0("within ", x@percentage, "% of ")
549		),
550	6x	dose_label,
551	6x	".\n\n"
552		)
553	6x	if (asis) {
554	2x	rv <- knitr::asis_output(rv)
555		}
556	6x	rv
557		}
558
559		# StoppingCohortsNearDose ----
560
561		#' @description `r lifecycle::badge("experimental")`
562		#' @param asis (`flag`)\cr Not used at present
563		#' @inheritParams knit_print.StoppingTargetProb
564		#' @rdname knit_print
565		#' @export
566		#' @method knit_print StoppingCohortsNearDose
567		knit_print.StoppingCohortsNearDose <- function(
568		x,
569		...,
570		dose_label = "the next best dose",
571		asis = TRUE
572		) {
573	8x	assert_flag(asis)
574	6x	assert_character(dose_label, len = 1, any.missing = FALSE)
575
576	6x	rv <- paste0(
577	6x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
578	6x	"If ",
579	6x	x@nCohorts,
580	6x	" or more cohorts have been treated ",
581	6x	ifelse(
582	6x	x@percentage == 0,
583	6x	"at ",
584	6x	paste0("within ", x@percentage, "% of ")
585		),
586	6x	dose_label,
587	6x	".\n\n"
588		)
589
590	6x	if (asis) {
591	2x	rv <- knitr::asis_output(rv)
592		}
593	6x	rv
594		}
595
596		# StoppingMissingDose ----
597
598		#' @description `r lifecycle::badge("experimental")`
599		#' @param asis (`flag`)\cr Not used at present
600		#' @rdname knit_print
601		#' @export
602		#' @method knit_print StoppingMissingDose
603		knit_print.StoppingMissingDose <- function(
604		x,
605		...,
606		asis = TRUE
607		) {
608	8x	assert_flag(asis)
609
610	6x	rv <- paste0(
611	6x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
612	6x	"If the dose returned by <code>nextBest()</code> is ",
613	6x	"<code>NA</code>, or if the trial includes a placebo dose, the placebo dose.\n\n"
614		)
615
616	6x	if (asis) {
617	2x	rv <- knitr::asis_output(rv)
618		}
619	6x	rv
620		}

1		##' @include helpers.R
2		##' @include Model-class.R
3		NULL
4
5		# nolint start
6
7		##' Convert prior quantiles (lower, median, upper) to logistic (log)
8		##' normal model
9		##'
10		##' This function uses generalized simulated annealing to optimize
11		##' a \code{\linkS4class{LogisticNormal}} model to be as close as possible
12		##' to the given prior quantiles.
13		##'
14		##' @param dosegrid the dose grid
15		##' @param refDose the reference dose
16		##' @param lower the lower quantiles
17		##' @param median the medians
18		##' @param upper the upper quantiles
19		##' @param level the credible level of the (lower, upper) intervals (default:
20		##' 0.95)
21		##' @param logNormal use the log-normal prior? (not default) otherwise, the
22		##' normal prior for the logistic regression coefficients is used
23		##' @param parstart starting values for the parameters. By default, these
24		##' are determined from the medians supplied.
25		##' @param parlower lower bounds on the parameters (intercept alpha and the
26		##' slope beta, the corresponding standard deviations and the correlation.)
27		##' @param parupper upper bounds on the parameters
28		##' @param seed seed for random number generation
29		##' @param verbose be verbose? (default)
30		##' @param control additional options for the optimisation routine, see
31		##' \code{\link[GenSA]{GenSA}} for more details
32		##' @return a list with the best approximating \code{model}
33		##' (\code{\linkS4class{LogisticNormal}} or
34		##' \code{\linkS4class{LogisticLogNormal}}), the resulting \code{quantiles}, the
35		##' \code{required} quantiles and the \code{distance} to the required quantiles,
36		##' as well as the final \code{parameters} (which could be used for running the
37		##' algorithm a second time)
38		##'
39		##' @importFrom GenSA GenSA
40		##' @importFrom mvtnorm rmvnorm
41		##' @export
42		##' @keywords programming
43		Quantiles2LogisticNormal <- function(
44		dosegrid,
45		refDose,
46		lower,
47		median,
48		upper,
49		level = 0.95,
50		logNormal = FALSE,
51		parstart = NULL,
52		parlower = c(-10, -10, 0, 0, -0.95),
53		parupper = c(10, 10, 10, 10, 0.95),
54		seed = 12345,
55		verbose = TRUE,
56		control = list(
57		threshold.stop = 0.01,
58		maxit = 50000,
59		temperature = 50000,
60		max.time = 600
61		)
62		) {
63		## extracts and checks
64	2x	nDoses <- length(dosegrid)
65
66	2x	assert_flag(logNormal)
67	2x	assert_flag(verbose)
68	2x	assert_probability(level, bounds_closed = FALSE)
69	2x	stopifnot(
70	2x	!is.unsorted(dosegrid, strictly = TRUE),
71		## the medians must be monotonically increasing:
72	2x	!is.unsorted(median),
73	2x	identical(length(lower), nDoses),
74	2x	identical(length(median), nDoses),
75	2x	identical(length(upper), nDoses),
76	2x	all(lower < median),
77	2x	all(upper > median),
78	2x	identical(length(parlower), 5L),
79	2x	identical(length(parupper), 5L),
80	2x	all(parlower < parstart),
81	2x	all(parstart < parupper)
82		)
83
84		## put verbose argument in the control list
85	2x	control$verbose <- verbose
86
87		## parametrize in terms of the means for the intercept alpha and the
88		## (log) slope beta,
89		## the corresponding standard deviations and the correlation.
90		## Define start values for optimisation:
91	2x	startValues <-
92	2x	if (is.null(parstart)) {
93		## find approximate means for alpha and slope beta
94		## from fitting logistic model to medians:
95	1x	startAlphaBeta <-
96	1x	coef(lm(I(logit(median)) ~ I(log(dosegrid / refDose))))
97
98		## overall starting values:
99	1x	c(
100	1x	meanAlpha = startAlphaBeta[1],
101	1x	meanBeta = if (logNormal) log(startAlphaBeta[2]) else startAlphaBeta[2],
102	1x	sdAlpha = 1,
103	1x	sdBeta = 1,
104	1x	correlation = 0
105		)
106		} else {
107	1x	parstart
108		}
109
110		## what is the target function which we want to minimize?
111	2x	target <- function(param) {
112		## form the mean vector and covariance matrix
113	4x	mean <- param[1:2]
114	4x	cov <- matrix(
115	4x	c(
116	4x	param[3]^2,
117	4x	prod(param[3:5]),
118	4x	prod(param[3:5]),
119	4x	param[4]^2
120		),
121	4x	nrow = 2L,
122	4x	ncol = 2L
123		)
124
125		## simulate from the corresponding normal distribution
126	4x	set.seed(seed)
127	4x	normalSamples <- mvtnorm::rmvnorm(
128	4x	n = 1e4L,
129	4x	mean = mean,
130	4x	sigma = cov
131		)
132
133		## extract separate coefficients
134	4x	alphaSamples <- normalSamples[, 1L]
135	4x	betaSamples <- if (logNormal) {
136	2x	exp(normalSamples[, 2L])
137		} else {
138	2x	normalSamples[, 2L]
139		}
140
141		## and compute resulting quantiles
142	4x	quants <- matrix(
143	4x	nrow = length(dosegrid),
144	4x	ncol = 3L
145		)
146	4x	colnames(quants) <- c("lower", "median", "upper")
147
148		## process each dose after another:
149	4x	for (i in seq_along(dosegrid)) {
150		## create samples of the probability
151	20x	probSamples <-
152	20x	plogis(alphaSamples + betaSamples * log(dosegrid[i] / refDose))
153
154		## compute lower, median and upper quantile
155	20x	quants[i, ] <-
156	20x	quantile(probSamples, probs = c((1 - level) / 2, 0.5, (1 + level) / 2))
157		}
158
159		## now we can compute the target value
160	4x	ret <- max(abs(quants - c(lower, median, upper)))
161	4x	return(structure(ret, mean = mean, cov = cov, quantiles = quants))
162		}
163
164	2x	set.seed(seed)
165		## now optimise the target
166	2x	genSAres <- GenSA::GenSA(
167	2x	par = startValues,
168	2x	fn = target,
169	2x	lower = parlower,
170	2x	upper = parupper,
171	2x	control = control
172		)
173	2x	distance <- genSAres$value
174	2x	pars <- genSAres$par
175	2x	targetRes <- target(pars)
176
177		## and construct the model
178	2x	ret <-
179	2x	if (logNormal) {
180	1x	LogisticLogNormal(
181	1x	mean = attr(targetRes, "mean"),
182	1x	cov = attr(targetRes, "cov"),
183	1x	ref_dose = refDose
184		)
185		} else {
186	1x	LogisticNormal(
187	1x	mean = attr(targetRes, "mean"),
188	1x	cov = attr(targetRes, "cov"),
189	1x	ref_dose = refDose
190		)
191		}
192
193		## return it together with the resulting distance and the quantiles
194	2x	return(list(
195	2x	model = ret,
196	2x	parameters = pars,
197	2x	quantiles = attr(targetRes, "quantiles"),
198	2x	required = cbind(lower, median, upper),
199	2x	distance = distance
200		))
201		}
202
203		# nolint end
204
205		#' Helper for Minimal Informative Unimodal Beta Distribution
206		#'
207		#' As defined in Neuenschwander et al (2008), this function computes the
208		#' parameters of the minimal informative unimodal beta distribution, given the
209		#' request that the p-quantile should be q, i.e. `X ~ Be(a, b)` with
210		#' `Pr(X <= q) = p`.
211		#'
212		#' @param p (`number`)\cr the probability.
213		#' @param q (`number`)\cr the quantile.
214		#' @return A list with the two resulting beta parameters `a` and `b`.
215		#'
216		#' @keywords internal
217		h_get_min_inf_beta <- function(p, q) {
218	3x	assert_probability(p, bounds_closed = FALSE)
219	3x	assert_probability(q, bounds_closed = FALSE)
220
221	3x	if (q > p) {
222	1x	list(
223	1x	a = log(p) / log(q),
224	1x	b = 1
225		)
226		} else {
227	2x	list(
228	2x	a = 1,
229	2x	b = log(1 - p) / log(1 - q)
230		)
231		}
232		}
233
234		# nolint start
235
236		##' Construct a minimally informative prior
237		##'
238		##' This function constructs a minimally informative prior, which is captured in
239		##' a \code{\linkS4class{LogisticNormal}} (or
240		##' \code{\linkS4class{LogisticLogNormal}}) object.
241		##'
242		##' Based on the proposal by Neuenschwander et al (2008, Statistics in
243		##' Medicine), a minimally informative prior distribution is constructed. The
244		##' required key input is the minimum (\eqn{d_{1}} in the notation of the
245		##' Appendix A.1 of that paper) and the maximum value (\eqn{d_{J}}) of the dose
246		##' grid supplied to this function. Then \code{threshmin} is the probability
247		##' threshold \eqn{q_{1}}, such that any probability of DLT larger than
248		##' \eqn{q_{1}} has only 5% probability. Therefore \eqn{q_{1}} is the 95%
249		##' quantile of the beta distribution and hence \eqn{p_{1} = 0.95}. Likewise,
250		##' \code{threshmax} is the probability threshold \eqn{q_{J}}, such that any
251		##' probability of DLT smaller than \eqn{q_{J}} has only 5% probability
252		##' (\eqn{p_{J} = 0.05}). The probabilities \eqn{1 - p_{1}} and \eqn{p_{J}} can be
253		##' controlled with the arguments \code{probmin} and \code{probmax}, respectively.
254		##' Subsequently, for all doses supplied in the
255		##' \code{dosegrid} argument, beta distributions are set up from the assumption
256		##' that the prior medians are linear in log-dose on the logit scale, and
257		##' \code{\link{Quantiles2LogisticNormal}} is used to transform the resulting
258		##' quantiles into an approximating \code{\linkS4class{LogisticNormal}} (or
259		##' \code{\linkS4class{LogisticLogNormal}}) model. Note that the reference dose
260		##' is not required for these computations.
261		##'
262		##' @param dosegrid the dose grid
263		##' @param refDose the reference dose
264		##' @param threshmin Any toxicity probability above this threshold would
265		##' be very unlikely (see \code{probmin}) at the minimum dose (default: 0.2)
266		##' @param threshmax Any toxicity probability below this threshold would
267		##' be very unlikely (see \code{probmax}) at the maximum dose (default: 0.3)
268		##' @param probmin the prior probability of exceeding \code{threshmin} at the
269		##' minimum dose (default: 0.05)
270		##' @param probmax the prior probability of being below \code{threshmax} at the
271		##' maximum dose (default: 0.05)
272		##' @param \dots additional arguments for computations, see
273		##' \code{\link{Quantiles2LogisticNormal}}, e.g. \code{refDose} and
274		##' \code{logNormal=TRUE} to obtain a minimal informative log normal prior.
275		##' @return see \code{\link{Quantiles2LogisticNormal}}
276		##'
277		##' @example examples/MinimalInformative.R
278		##' @export
279		##' @keywords programming
280		MinimalInformative <- function(
281		dosegrid,
282		refDose,
283		threshmin = 0.2,
284		threshmax = 0.3,
285		probmin = 0.05,
286		probmax = 0.05,
287		...
288		) {
289		## extracts and checks
290	!	nDoses <- length(dosegrid)
291
292	!	assert_probability(threshmin, bounds_closed = FALSE)
293	!	assert_probability(threshmax, bounds_closed = FALSE)
294	!	assert_probability(probmin, bounds_closed = FALSE)
295	!	assert_probability(probmax, bounds_closed = FALSE)
296	!	stopifnot(
297	!	!is.unsorted(dosegrid, strictly = TRUE)
298		)
299	!	xmin <- dosegrid[1]
300	!	xmax <- dosegrid[nDoses]
301
302		## derive the beta distributions at the lowest and highest dose
303	!	betaAtMin <- h_get_min_inf_beta(
304	!	q = threshmin,
305	!	p = 1 - probmin
306		)
307	!	betaAtMax <- h_get_min_inf_beta(
308	!	q = threshmax,
309	!	p = probmax
310		)
311
312		## get the medians of those beta distributions
313	!	medianMin <- with(
314	!	betaAtMin,
315	!	qbeta(p = 0.5, a, b)
316		)
317	!	medianMax <- with(
318	!	betaAtMax,
319	!	qbeta(p = 0.5, a, b)
320		)
321
322		## now determine the medians of all beta distributions
323	!	beta <- (logit(medianMax) - logit(medianMin)) / (log(xmax) - log(xmin))
324	!	alpha <- logit(medianMax) - beta * log(xmax / refDose)
325	!	medianDosegrid <- plogis(alpha + beta * log(dosegrid / refDose))
326
327		## finally for all doses calculate 95% credible interval bounds
328		## (lower and upper)
329	!	lower <- upper <- dosegrid
330	!	for (i in seq_along(dosegrid)) {
331		## get min inf beta distribution
332	!	thisMinBeta <- h_get_min_inf_beta(
333	!	p = 0.5,
334	!	q = medianDosegrid[i]
335		)
336
337		## derive required quantiles
338	!	lower[i] <- with(
339	!	thisMinBeta,
340	!	qbeta(p = 0.025, a, b)
341		)
342	!	upper[i] <- with(
343	!	thisMinBeta,
344	!	qbeta(p = 0.975, a, b)
345		)
346		}
347
348		## now go to Quantiles2LogisticNormal
349	!	Quantiles2LogisticNormal(
350	!	dosegrid = dosegrid,
351	!	refDose = refDose,
352	!	lower = lower,
353	!	median = medianDosegrid,
354	!	upper = upper,
355	!	level = 0.95,
356		...
357		)
358		}
359
360		# nolint end

1		#' Helper Function to Set and Save the RNG Seed
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' This code is basically copied from `stats:::simulate.lm`.
6		#'
7		#' @param seed an object specifying if and how the random number generator
8		#' should be initialized ("seeded"). Either `NULL` (default) or an
9		#' integer that will be used in a call to [set.seed()] before
10		#' simulating the response vectors. If set, the value is saved as the
11		#' `seed` slot of the returned object. The default, `NULL` will
12		#' not change the random generator state.
13		#' @return The integer vector containing the random number generate state will
14		#' be returned, in order to call this function with this input to reproduce
15		#' the obtained simulation results.
16		#'
17		#' @export
18		set_seed <- function(seed = NULL) {
19	32x	assert_number(seed, null.ok = TRUE)
20
21	32x	if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
22	!	runif(1)
23		}
24
25	32x	if (is.null(seed)) {
26	4x	get(".Random.seed", envir = .GlobalEnv)
27		} else {
28	28x	seed <- as.integer(seed)
29	28x	r_seed <- get(".Random.seed", envir = .GlobalEnv)
30		# Make sure r_seed exists in parent frame.
31	28x	assign(".r_seed", r_seed, envir = parent.frame())
32	28x	set.seed(seed)
33		# Here we need the r_seed in the parent.frame!
34	28x	do.call(
35	28x	"on.exit",
36	28x	list(quote(assign(".Random.seed", .r_seed, envir = .GlobalEnv))),
37	28x	envir = parent.frame()
38		)
39	28x	structure(seed, kind = as.list(RNGkind()))
40		}
41		}
42
43		#' Helper Function to Obtain Simulation Results List
44		#'
45		#' The function `fun` can use variables that are visible to itself.
46		#' The names of these variables have to be given in the vector `vars`.
47		#'
48		#' @param fun (`function`)\cr the simulation function for a single iteration, which takes as
49		#' single parameter the iteration index.
50		#' @param nsim number of simulations to be conducted.
51		#' @param vars names of the variables.
52		#' @param parallel should the simulation runs be parallelized across the
53		#' clusters of the computer?
54		#' @param n_cores how many cores should be used for parallel computing?
55		#' @return The list with all simulation results (one iteration corresponds
56		#' to one list element).
57		#'
58		#' @importFrom parallel makeCluster
59		#' @importFrom parallelly availableCores
60		#' @keywords internal programming
61		get_result_list <- function(
62		fun,
63		nsim,
64		vars,
65		parallel,
66		n_cores
67		) {
68	32x	assert_flag(parallel)
69	31x	assert_integerish(n_cores, lower = 1)
70
71	30x	if (!parallel) {
72	30x	lapply(
73	30x	X = seq_len(nsim),
74	30x	FUN = fun
75		)
76		} else {
77		# Process all simulations.
78	!	cores <- min(
79	!	as.integer(n_cores),
80	!	parallelly::availableCores()
81		)
82
83		# Start the cluster.
84	!	cl <- parallel::makeCluster(cores)
85
86		# Load the required R package.
87	!	parallel::clusterEvalQ(cl, {
88	!	library(crmPack)
89	!	NULL
90		})
91
92		# Export local variables from the caller environment.
93		# Note: parent.frame() is different from parent.env() which returns
94		# the environment where this function has been defined!
95	!	parallel::clusterExport(
96	!	cl = cl,
97	!	varlist = vars,
98	!	envir = parent.frame()
99		)
100
101		# Export all global variables.
102	!	parallel::clusterExport(
103	!	cl = cl,
104	!	varlist = ls(.GlobalEnv)
105		)
106
107		# Load user extensions from global options.
108	!	crmpack_extensions <- getOption("crmpack_extensions")
109	!	if (is.null(crmpack_extensions) != TRUE) {
110	!	tryCatch(
111		{
112	!	parallel::clusterCall(cl, crmpack_extensions)
113		},
114	!	error = function(e) {
115	!	stop("Failed to export crmpack_extensions: ", e$message)
116		}
117		)
118		}
119
120		# Do the computations in parallel.
121	!	res <- parallel::parLapply(
122	!	cl = cl,
123	!	X = seq_len(nsim),
124	!	fun = fun
125		)
126
127		# Stop the cluster.
128	!	parallel::stopCluster(cl)
129
130	!	res
131		}
132		}
133
134
135		#' Helper Function to call truth calculation
136		#'
137		#' @param dose (`number`)\cr current dose.
138		#' @param truth (`function`)\cr defines the true probability for a DLT at a dose.
139		#' @param this_args (`data.frame`)\cr list of arguments for the truth.
140		#' @return The updated `this_truth`.
141		#'
142		#' @keywords internal
143		h_this_truth <- function(dose, this_args, truth) {
144	98x	do.call(
145	98x	truth,
146		## First argument: the dose
147	98x	c(
148	98x	dose,
149		## Following arguments
150	98x	this_args
151		)
152		)
153		}
154
155
156		#' Helper Function to create return list for Simulations output
157		#'
158		#' @param resultList (`list`)\cr raw iteration output.
159		#'
160		#' @return aggregated output for simulation object `list`.
161		#'
162		#' @keywords internal
163		h_simulations_output_format <- function(resultList) {
164		## put everything in the Simulations format:
165
166		## setup the list for the simulated data objects
167	10x	dataList <- lapply(resultList, "[[", "data")
168
169		## the vector of the final dose recommendations
170	10x	recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))
171
172		## setup the list for the final fits
173	10x	fitList <- lapply(resultList, "[[", "fit")
174
175		## the reasons for stopping
176	10x	stopReasons <- lapply(resultList, "[[", "stop")
177
178		# individual stopping rule results as matrix, labels as column names
179	10x	stopResults <- lapply(resultList, "[[", "report_results")
180	10x	stop_matrix <- as.matrix(do.call(rbind, stopResults))
181
182		# Result list of additional statistical summary.
183	10x	additional_stats <- lapply(resultList, "[[", "additional_stats")
184
185	10x	return(list(
186	10x	dataList = dataList,
187	10x	recommendedDoses = recommendedDoses,
188	10x	fitList = fitList,
189	10x	stopReasons = stopReasons,
190	10x	stopResults = stopResults,
191	10x	additional_stats = additional_stats,
192	10x	stop_matrix = stop_matrix
193		))
194		}
195
196
197		#' Helper function to recursively unpack stopping rules and return lists with
198		#' logical value and label given
199		#'
200		#' @param stopit_tree object from simulate method
201		#' @return named list
202
203		h_unpack_stopit <- function(stopit_tree) {
204	467x	label <- attr(stopit_tree, "report_label")
205	467x	value <- stopit_tree[1]
206	467x	names(value) <- label
207	467x	value
208	467x	if (is.null(attr(stopit_tree, "individual"))) {
209	389x	return(value)
210		} else {
211	78x	return(unlist(c(
212	78x	value,
213	78x	lapply(attr(stopit_tree, "individual"), h_unpack_stopit)
214		)))
215		}
216		}
217
218
219		#' Helper function to determine the dlts including first separate and placebo
220		#' condition
221		#'
222		#' @param data (`Data`)\cr what data to start from.
223		#' @param dose (`number`)\cr current dose.
224		#' @param prob (`function`)\cr defines the true probability for a DLT at a dose.
225		#' @param prob_placebo (`function`)\cr defines the true probability for a DLT at a placebo condition.
226		#' @param cohort_size (`number`)\cr the cohort size to use.
227		#' @param cohort_size_placebo (`number`)\cr the cohort size to use for placebo condition.
228		#' @param dose_grid (`numeric`)\cr the dose_grid as specified by the user.
229		#' @param first_separate (`flag`)\cr whether the first patient is enrolled separately.
230		#' @return updated data object
231		#' @keywords internal
232
233		h_determine_dlts <- function(
234		data,
235		dose,
236		prob,
237		prob_placebo,
238		cohort_size,
239		cohort_size_placebo,
240		dose_grid,
241		first_separate
242		) {
243	216x	assert_class(data, "Data")
244	216x	assert_number(dose)
245	216x	assert_number(prob)
246	216x	assert_number(cohort_size)
247	216x	assert_flag(first_separate)
248
249	216x	if (first_separate && cohort_size > 1) {
250	33x	dlts <- rbinom(n = 1, size = 1, prob = prob)
251	33x	if ((data@placebo) && cohort_size_placebo > 0) {
252	4x	dlts_placebo <- rbinom(n = 1, size = 1, prob = prob_placebo)
253		}
254	33x	if (dlts == 0) {
255	20x	dlts <- c(dlts, rbinom(n = cohort_size - 1L, size = 1, prob = prob))
256	20x	if ((data@placebo) && cohort_size_placebo > 0) {
257	4x	dlts_placebo <- c(
258	4x	dlts_placebo,
259	4x	rbinom(
260	4x	n = cohort_size_placebo, # cohort_size_placebo - 1?
261	4x	size = 1,
262	4x	prob = prob_placebo
263		)
264		)
265		}
266		}
267		} else {
268	183x	dlts <- rbinom(n = cohort_size, size = 1, prob = prob)
269	183x	if ((data@placebo) && cohort_size_placebo > 0) {
270	11x	dlts_placebo <- rbinom(
271	11x	n = cohort_size_placebo,
272	11x	size = 1,
273	11x	prob = prob_placebo
274		)
275		}
276		}
277
278	216x	if ((data@placebo) && cohort_size_placebo > 0) {
279	15x	this_data <- update(
280	15x	object = data,
281	15x	x = dose_grid,
282	15x	y = dlts_placebo,
283	15x	check = FALSE
284		)
285
286		## update the data with active dose
287	15x	this_data <- update(
288	15x	object = this_data,
289	15x	x = dose,
290	15x	y = dlts,
291	15x	new_cohort = FALSE
292		)
293		} else {
294		## update the data with this cohort
295	201x	this_data <- update(
296	201x	object = data,
297	201x	x = dose,
298	201x	y = dlts
299		)
300		}
301	216x	return(this_data)
302		}

1		# v_mcmc_options ----
2
3		#' Internal Helper Functions for Validation of [`McmcOptions`] Objects
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' These functions are only used internally to validate the format of an input
8		#' [`McmcOptions`] or inherited classes and therefore not exported.
9		#'
10		#' @name v_mcmcoptions_objects
11		#' @param object (`McmcOptions`)\cr object to validate.
12		#' @return A `character` vector with the validation failure messages,
13		#' or `TRUE` in case validation passes.
14		NULL
15
16		#' @describeIn v_mcmcoptions_objects validates that the [`McmcOptions`]
17		#' object contains valid integer scalars `iterations`, `burnin` and `step`
18		#' as well as proper parameters for Random Number Generator.
19		v_mcmc_options <- function(object) {
20	4x	v <- Validate()
21	4x	allowed_rng_kinds <- c(
22	4x	"base::Wichmann-Hill",
23	4x	"base::Marsaglia-Multicarry",
24	4x	"base::Super-Duper",
25	4x	"base::Mersenne-Twister",
26	4x	NA_character_
27		)
28
29	4x	v$check(
30	4x	test_int(object@iterations, lower = 1L),
31	4x	"iterations must be integer scalar greater than or equal to 1"
32		)
33	4x	v$check(
34	4x	test_int(object@burnin, lower = 0L),
35	4x	"burn-in must be non-negative integer scalar"
36		)
37		# This below check should not be conducted in above test, using
38		# `upper = object@iterations -1` argument, since object@iterations might be
39		# not-valid. In such a case `test_int` throws an internal error.
40	4x	v$check(
41	4x	test_true(object@burnin < object@iterations),
42	4x	"burn-in must be lower than iterations"
43		)
44	4x	v$check(
45	4x	test_int(object@step, lower = 1L),
46	4x	"step must be integer scalar greater than or equal to 1"
47		)
48
49	4x	is_rng_kind_scalar <- test_string(object@rng_kind, na.ok = TRUE)
50	4x	v$check(is_rng_kind_scalar, "rng_kind must be a single string")
51	4x	v$check(
52	4x	test_subset(object@rng_kind, allowed_rng_kinds),
53	4x	paste0(
54	4x	"rng_kind must one of the following: ",
55	4x	paste(allowed_rng_kinds, collapse = ", "),
56	4x	". User specifies the rng_kind without `base::` prefix"
57		)
58		)
59
60	4x	is_rng_seed_scalar <- test_int(object@rng_seed, na.ok = TRUE)
61	4x	v$check(is_rng_seed_scalar, "rng_seed must be an integer scalar")
62
63		# Below `if` condition is not only reasonable but also needed as R CMD check
64		# is activating some stricter checks and it fails when arguments to `\|\|` are
65		# not scalars, even if `\|\|` works well with vectors of length > 1.
66	4x	if (is_rng_kind_scalar && is_rng_seed_scalar) {
67	3x	v$check(
68	3x	!is.na(object@rng_kind) \|\| is.na(object@rng_seed),
69	3x	"rng_seed supplied but rng_kind not set"
70		)
71		}
72	4x	v$result()
73		}

1		# These functions will need to be amended to support the report_label slot if
2		# and when it is added to NextBest classes
3
4		# NextBestMTD ----
5
6		#' @description `r lifecycle::badge("experimental")`
7		#' @inheritParams knit_print.StoppingTargetProb
8		#' @param target_label (`character`)\cr the term used to describe the target
9		#' toxicity rate
10		#' @rdname knit_print
11		#' @export
12		#' @method knit_print NextBestMTD
13		knit_print.NextBestMTD <- function(
14		x,
15		...,
16		target_label = "the 25th centile",
17		tox_label = "toxicity",
18		asis = TRUE
19		) {
20		# Validate
21	21x	assert_flag(asis)
22	19x	assert_character(target_label, len = 1, any.missing = FALSE)
23
24	19x	tox_label <- h_prepare_labels(tox_label)
25		# Execute
26	19x	rv <- paste0(
27	19x	"The dose level recommended for the next cohort will be selected as follows:\n\n",
28	19x	"- First, ",
29	19x	target_label,
30	19x	" of the posterior distribution of ",
31	19x	tox_label[1],
32	19x	" will be calculated for all dose levels that are eligible according to the ",
33	19x	" Increments rule.\n",
34	19x	"- Next, the \"target dose\" (which may not be part of the dose grid) for which ",
35	19x	target_label,
36	19x	" of the posterior distribution of ",
37	19x	tox_label[1],
38	19x	" is exactly equal to the target rate of ",
39	19x	x@target,
40	19x	" will be determined.\n",
41	19x	"- Finally, the dose level whose absolute distance from the target dose ",
42	19x	"is smallest will be selected as the recommended dose for the next cohort\n\n"
43		)
44
45	19x	if (asis) {
46	4x	rv <- knitr::asis_output(rv)
47		}
48	19x	rv
49		}
50
51		# NextBestNCRM ----
52
53		#' @description `r lifecycle::badge("experimental")`
54		#' @inheritParams knit_print.StoppingTargetProb
55		#' @rdname knit_print
56		#' @export
57		#' @method knit_print NextBestNCRM
58		knit_print.NextBestNCRM <- function(
59		x,
60		...,
61		tox_label = "toxicity",
62		asis = TRUE
63		) {
64		# Validate
65	32x	assert_flag(asis)
66	30x	assert_character(tox_label, max.len = 2, any.missing = FALSE)
67
68		# Execute
69	30x	rv <- paste0(
70	30x	"The dose recommended for the next cohort will be chosen in the following ",
71	30x	"way. First, doses that are ineligible according to the increments rule ",
72	30x	"will be discarded. Next, any dose for which the mean posterior probability of ",
73	30x	tox_label,
74	30x	" being in the overdose range - (",
75	30x	x@overdose[1],
76		", ",
77	30x	x@overdose[2],
78	30x	"] - is ",
79	30x	x@max_overdose_prob,
80	30x	" or more will also be discarded. Finally, the dose amongst those remaining ",
81	30x	"which has the highest chance that the mean posterior probability of ",
82	30x	tox_label,
83	30x	" is in the target ",
84	30x	tox_label,
85	30x	" range of ",
86	30x	x@target[1],
87	30x	" to ",
88	30x	x@target[2],
89	30x	" (inclusive) will be selected.\n\n"
90		)
91
92	30x	if (asis) {
93	2x	rv <- knitr::asis_output(rv)
94		}
95	30x	rv
96		}
97
98		# NextBestThreePlusThree ----
99
100		#' @description `r lifecycle::badge("experimental")`
101		#' @param label (`character`)\cr The term used to label the participants.
102		#' @param tox_label (`character`)\cr the term used to describe toxicity. See
103		#' Usage Notes below.
104		#' See Usage Notes below.
105		#' @section Usage Notes:
106		#' This section describes the use of `label` and `tox_label`, collectively
107		#' referred to as `label`s.
108		#' A `label` should be a scalar or a vector of length 2. If a scalar, it is
109		#' converted by adding a second element that is equal to the first, suffixed by `s`.
110		#' For example, `tox_label = "DLT"` becomes `tox_label = c("DLT", "DLTs")`. The
111		#' first element of the vector is used to describe a count of 1. The second
112		#' is used in all other cases.
113		#' @rdname knit_print
114		#' @export
115		#' @method knit_print NextBestThreePlusThree
116		knit_print.NextBestThreePlusThree <- function(
117		x,
118		...,
119		tox_label = c("toxicity", "toxicities"),
120		label = "participant",
121		asis = TRUE
122		) {
123		# Validate
124	14x	assert_flag(asis)
125
126		# Prepare
127	12x	tox_label <- h_prepare_labels(tox_label)
128	12x	label <- h_prepare_labels(label)
129
130		# Execute
131	12x	rv <- paste0(
132	12x	"The dose recommended for the next cohort will be chosen using the \"Three ",
133	12x	"Plus Three\" rule.\n\n- If no ",
134	12x	tox_label[2],
135	12x	" have been reported at the current dose level, escalate by one dose level.\n",
136	12x	"- If the observed ",
137	12x	tox_label[1],
138	12x	" rate at the current dose level is exactly 1/3 and no more than three ",
139	12x	label[2],
140	12x	" treated at the current dose level are evaluable, remain at the current ",
141	12x	"dose level.\n",
142	12x	"- Otherwise, recommend that the trial stops and identify the MTD as dose ",
143	12x	"level immediately below the current one.\n\n"
144		)
145
146	12x	if (asis) {
147	2x	rv <- knitr::asis_output(rv)
148		}
149	12x	rv
150		}
151
152		# NextBestDualEndpoint ----
153
154		#' @description `r lifecycle::badge("experimental")`
155		#' @inheritParams knit_print.StoppingTargetProb
156		#' @param biomarker_label (`character`)\cr the term used to describe the biomarker
157		#' @param biomarker_units (`character`)\cr the units in which the biomarker is
158		#' measured
159		#' @rdname knit_print
160		#' @export
161		#' @method knit_print NextBestDualEndpoint
162		knit_print.NextBestDualEndpoint <- function(
163		x,
164		...,
165		tox_label = "toxicity",
166		biomarker_label = "the biomarker",
167		biomarker_units = ifelse(x@target_relative, "%", ""),
168		asis = TRUE
169		) {
170	14x	assert_flag(asis)
171	12x	assert_character(tox_label, len = 1, any.missing = FALSE)
172	12x	assert_character(biomarker_label, len = 1, any.missing = FALSE)
173	12x	assert_character(biomarker_units, len = 1, any.missing = FALSE)
174
175	12x	rv <- paste0(
176	12x	"The dose recommended for the next cohort will be chosen in the following ",
177	12x	"way. First, doses that are ineligible according to the increments rule ",
178	12x	"will be discarded. Next, any dose for which the mean posterior probability of ",
179	12x	tox_label,
180	12x	" being in the overdose range - (",
181	12x	x@overdose[1],
182		", ",
183	12x	x@overdose[2],
184	12x	"] - is ",
185	12x	x@max_overdose_prob,
186	12x	" or more will also be discarded. Finally, the dose amongst those remaining ",
187	12x	"which has the highest chance that the mean posterior probability that ",
188	12x	biomarker_label,
189	12x	" is in the target range for ",
190	12x	biomarker_label,
191	12x	", which is ",
192	12x	x@target[1],
193	12x	ifelse(
194	12x	x@target_relative,
195		"",
196	12x	stringr::str_squish(paste0(" ", biomarker_units))
197		),
198	12x	" to ",
199	12x	x@target[2],
200	12x	ifelse(
201	12x	x@target_relative,
202		"",
203	12x	stringr::str_squish(paste0(" ", biomarker_units))
204		),
205	12x	" (inclusive),",
206	12x	ifelse(
207	12x	x@target_relative,
208	12x	paste0(" of the maximum ", biomarker_label, " value"),
209		""
210		),
211	12x	" will be selected, provided that this probability exceeds ",
212	12x	x@target_thresh,
213	12x	". If no dose meets this threshold, then the highest eligible dose will ",
214	12x	"be selected.\n\n"
215		)
216
217	12x	if (asis) {
218	2x	rv <- knitr::asis_output(rv)
219		}
220	12x	rv
221		}
222
223		# NextBestMinDist ----
224
225		#' @description `r lifecycle::badge("experimental")`
226		#' @inheritParams knit_print.StoppingTargetProb
227		#' @rdname knit_print
228		#' @export
229		#' @method knit_print NextBestMinDist
230		knit_print.NextBestMinDist <- function(
231		x,
232		...,
233		tox_label = "toxicity",
234		asis = TRUE
235		) {
236		# Validate
237	8x	assert_flag(asis)
238	6x	assert_character(tox_label, len = 1, any.missing = FALSE)
239
240		# Execute
241	6x	rv <- paste0(
242	6x	"The dose recommended for the next cohort will be the one which is both ",
243	6x	"eligible and which has the smallest absolute difference between ",
244	6x	"its mean posterior estimate of the probability of ",
245	6x	tox_label,
246	6x	" and the target ",
247	6x	tox_label,
248	6x	" rate [",
249	6x	x@target,
250	6x	"].\n\n"
251		)
252
253	6x	if (asis) {
254	2x	rv <- knitr::asis_output(rv)
255		}
256	6x	rv
257		}
258
259		# NextBestInfTheory ----
260
261		#' @description `r lifecycle::badge("experimental")`
262		#' @inheritParams knit_print.StoppingTargetProb
263		#' @param citation_text (`character`)\cr the text used to cite Mozgunov & Jaki
264		#' @param citation_link (`character`)\cr the link to Mozgunov & Jaki
265		#' @section Usage Notes:
266		#' To use a BibTeX-style citation, specify (for example) `citation_text =
267		#' "@MOZGUNOV", citation_link = ""`.
268		#' @rdname knit_print
269		#' @export
270		#' @method knit_print NextBestInfTheory
271		knit_print.NextBestInfTheory <- function(
272		x,
273		...,
274		tox_label = "toxicity",
275		citation_text = "Mozgunov & Jaki (2019)",
276		citation_link = "https://doi.org/10.1002/sim.8450",
277		asis = TRUE
278		) {
279		# Validate
280	8x	assert_flag(asis)
281	6x	assert_character(tox_label, len = 1, any.missing = FALSE)
282	6x	assert_character(citation_text, len = 1, any.missing = FALSE)
283	6x	assert_character(citation_link, len = 1, any.missing = FALSE)
284
285		# Execute
286	6x	rv <- paste0(
287	6x	"The recommended dose for the next cohort will be chosen using the ",
288	6x	"complex infinite bounds penalisation (CIBP) criterion of ",
289		"[",
290	6x	citation_text,
291		"]",
292	6x	ifelse(nchar(citation_link) > 0, paste0("(", citation_link, ")"), ""),
293	6x	". Let\n\n",
294	6x	"$$ \\delta(\\hat{p}_d, \\gamma) = \\frac{(\\hat{p}_d - \\gamma)^2}",
295	6x	"{\\hat{p}_d^a \\cdot (1 - \\hat{p}_d)^{2 - a}} $$\n\n",
296	6x	"where a is the non-centrality parameter with a value of ",
297	6x	x@asymmetry,
298	6x	", γ is the target ",
299	6x	tox_label,
300	6x	" rate with a value of ",
301	6x	x@target,
302	6x	" and $\\hat{p}_d$ is the mean posterior estimate of the probability of ",
303	6x	tox_label,
304	6x	" at dose level d.\n\n",
305	6x	"The recommended dose for the next cohort will be ",
306	6x	"the value of d that minimises $\\delta(\\hat{p}_d, \\gamma)$.\n\n"
307		)
308
309	6x	if (asis) {
310	2x	rv <- knitr::asis_output(rv)
311		}
312	6x	rv
313		}
314
315		# NextBestTD ----
316
317		#' @description `r lifecycle::badge("experimental")`
318		#' @inheritParams knit_print.StoppingTargetProb
319		#' @rdname knit_print
320		#' @export
321		#' @method knit_print NextBestTD
322		knit_print.NextBestTD <- function(
323		x,
324		...,
325		tox_label = "toxicity",
326		asis = TRUE
327		) {
328		# Validate
329	14x	assert_flag(asis)
330	12x	assert_character(tox_label, len = 1, any.missing = FALSE)
331
332		# Execute
333	12x	rv <- paste0(
334	12x	"The dose recommended for the next cohort will be the one which is both ",
335	12x	"eligible and which is the highest dose in the dose grid strictly less than ",
336	12x	"the dose (which may not be in the dose grid) that has a posterior plug-in ",
337	12x	"estimate of the probability of ",
338	12x	tox_label,
339	12x	" exactly equal to the target ",
340	12x	tox_label,
341	12x	" rate, either during [",
342	12x	x@prob_target_drt,
343	12x	"] or at the end of the trial [",
344	12x	x@prob_target_eot,
345	12x	"].\n\n"
346		)
347
348	12x	if (asis) {
349	2x	rv <- knitr::asis_output(rv)
350		}
351	12x	rv
352		}
353
354		# NextBestMaxGain ----
355
356		#' @description `r lifecycle::badge("experimental")`
357		#' @inheritParams knit_print.StoppingTargetProb
358		#' @rdname knit_print
359		#' @export
360		#' @method knit_print NextBestMaxGain
361		knit_print.NextBestMaxGain <- function(
362		x,
363		...,
364		tox_label = "toxicity",
365		asis = TRUE
366		) {
367		# Validate
368	14x	assert_flag(asis)
369	12x	assert_character(tox_label, len = 1, any.missing = FALSE)
370
371		# Execute
372	12x	rv <- paste0(
373	12x	"The dose recommended for the next cohort will be the one which is closest to ",
374	12x	"Gstar, the dose that maximises the gain for probability of ",
375	12x	tox_label,
376	12x	" exactly equal to the target ",
377	12x	tox_label,
378	12x	" rate, either during [",
379	12x	x@prob_target_drt,
380	12x	"] or at the end of the trial [",
381	12x	x@prob_target_eot,
382	12x	"].\n\n"
383		)
384
385	12x	if (asis) {
386	2x	rv <- knitr::asis_output(rv)
387		}
388	12x	rv
389		}
390
391		# NextBestProbMTDLTE ----
392
393		#' @description `r lifecycle::badge("experimental")`
394		#' @inheritParams knit_print.StoppingTargetProb
395		#' @rdname knit_print
396		#' @export
397		#' @method knit_print NextBestProbMTDLTE
398		knit_print.NextBestProbMTDLTE <- function(
399		x,
400		...,
401		tox_label = "toxicity",
402		asis = TRUE
403		) {
404		# Validate
405	8x	assert_flag(asis)
406	6x	assert_character(tox_label, len = 1, any.missing = FALSE)
407
408		# Execute
409	6x	rv <- paste0(
410	6x	"The dose recommended for the next cohort will be the dose level with ",
411	6x	"the highest probability of being the highest dose with an estimated ",
412	6x	"probability of ",
413	6x	tox_label,
414	6x	" less than or equal to ",
415	6x	x@target,
416	6x	".\n\n"
417		)
418
419	6x	if (asis) {
420	2x	rv <- knitr::asis_output(rv)
421		}
422	6x	rv
423		}
424
425		# NextBestProbMTDMinDist ----
426
427		#' @description `r lifecycle::badge("experimental")`
428		#' @inheritParams knit_print.StoppingTargetProb
429		#' @rdname knit_print
430		#' @export
431		#' @method knit_print NextBestProbMTDMinDist
432		knit_print.NextBestProbMTDMinDist <- function(
433		x,
434		...,
435		tox_label = "toxicity",
436		asis = TRUE
437		) {
438		# Validate
439	8x	assert_flag(asis)
440	6x	assert_character(tox_label, len = 1, any.missing = FALSE)
441
442		# Execute
443	6x	rv <- paste0(
444	6x	"The dose recommended for the next cohort will be the dose level with ",
445	6x	"the highest probability of being the highest dose with an estimated ",
446	6x	"probability of ",
447	6x	tox_label,
448	6x	" closest to ",
449	6x	x@target,
450	6x	".\n\n"
451		)
452
453	6x	if (asis) {
454	2x	rv <- knitr::asis_output(rv)
455		}
456	6x	rv
457		}
458
459		# NextBestNCRMLoss ----
460
461		#' @description `r lifecycle::badge("experimental")`
462		#' @inheritParams knit_print.StoppingTargetProb
463		#' @param format_func (`function`)\cr The function used to format the range table.
464		#' @importFrom rlang .data
465		#' @rdname knit_print
466		#' @export
467		#' @method knit_print NextBestNCRMLoss
468		knit_print.NextBestNCRMLoss <- function(
469		x,
470		...,
471		tox_label = "toxicity",
472		asis = TRUE,
473		format_func = h_knit_format_func
474		) {
475		# Validate
476	8x	assert_flag(asis)
477	6x	assert_character(tox_label, len = 1, any.missing = FALSE)
478
479		# Execute
480	6x	param <- list(...)
481	6x	param[["x"]] <- x %>%
482	6x	tidy() %>%
483	6x	dplyr::select(-MaxOverdoseProb)
484	6x	param[["col.names"]] <- c("Range", "Lower", "Upper", "Loss Coefficient")
485	6x	rv <- paste0(
486	6x	"The dose recommended for the next cohort will be chosen in the following ",
487	6x	"way:\n\n- First, the chance that the probability of ",
488	6x	tox_label,
489	6x	" falls into each of the underdose, target ",
490	6x	ifelse(
491	6x	any(x@unacceptable != c(1, 1)),
492	6x	", overdose and unacceptable",
493	6x	" and overdose"
494		),
495	6x	" dose ranges is calculated for element of the dose grid.\n",
496	6x	"- Next, the loss associated with each dose is calculated by multiplying ",
497	6x	"these probabilities by the corresponding loss coefficient and summing the result.\n",
498	6x	"- Then ineligible doses, and those with a probability of being in the ",
499	6x	ifelse(
500	6x	length(x@losses) == 3,
501	6x	"overdose range",
502	6x	"overdose or unaccaptable ranges"
503		),
504	6x	" that is greater than ",
505	6x	x@max_overdose_prob,
506	6x	", are discarded.\n",
507	6x	"- Finally, the dose level with the smallest loss is selected as the ",
508	6x	"recommended dose for the next cohort.\n\n",
509	6x	ifelse(
510	6x	toupper(tox_label) == tox_label,
511	6x	tox_label,
512	6x	stringr::str_to_sentence(tox_label)
513		),
514	6x	" ranges and loss coefficients are given in the following table:\n\n",
515	6x	paste((do.call(knitr::kable, param)) %>% format_func(), collapse = "\n"),
516	6x	"\n\n"
517		)
518
519	6x	if (asis) {
520	2x	rv <- knitr::asis_output(rv)
521		}
522	6x	rv
523		}
524
525		# NextBestTDsamples ----
526
527		#' @description `r lifecycle::badge("experimental")`
528		#' @inheritParams knit_print.StoppingTargetProb
529		#' @rdname knit_print
530		#' @export
531		#' @method knit_print NextBestTDsamples
532		knit_print.NextBestTDsamples <- function(
533		x,
534		...,
535		tox_label = "toxicity",
536		asis = TRUE
537		) {
538		# Validate
539	12x	assert_flag(asis)
540	10x	assert_character(tox_label, len = 1, any.missing = FALSE)
541
542		# Execute
543	10x	rv <- paste0(
544	10x	"The dose recommended for the next cohort will be the one which is both ",
545	10x	"eligible and which is the highest dose in the dose grid strictly less than ",
546	10x	"the dose (which may not be in the dose grid) that has a full Bayes posterior ",
547	10x	"estimate of the probability of ",
548	10x	tox_label,
549	10x	" exactly equal to the target ",
550	10x	tox_label,
551	10x	" rate, either during [",
552	10x	x@prob_target_drt,
553	10x	"] or at the end of the trial [",
554	10x	x@prob_target_eot,
555	10x	"].\n\n"
556		)
557
558	10x	if (asis) {
559	2x	rv <- knitr::asis_output(rv)
560		}
561	10x	rv
562		}
563
564
565		# NextBestMaxGainSamples ----
566
567		#' @description `r lifecycle::badge("experimental")`
568		#' @inheritParams knit_print.StoppingTargetProb
569		#' @rdname knit_print
570		#' @export
571		#' @method knit_print NextBestMaxGainSamples
572		knit_print.NextBestMaxGainSamples <- function(
573		x,
574		...,
575		tox_label = "toxicity",
576		asis = TRUE
577		) {
578		# Validate
579	14x	assert_flag(asis)
580	12x	assert_character(tox_label, len = 1, any.missing = FALSE)
581
582		# Execute
583	12x	rv <- paste0(
584	12x	"The dose recommended for the next cohort will be the one which is closest to ",
585	12x	"Gstar, the dose for which the full Bayes posterior estimate of the probability of ",
586	12x	tox_label,
587	12x	" maximises the gain relative to the target ",
588	12x	tox_label,
589	12x	" rate, either during [",
590	12x	x@prob_target_drt,
591	12x	"] or at the end of the trial [",
592	12x	x@prob_target_eot,
593	12x	"].\n\n"
594		)
595
596	12x	if (asis) {
597	2x	rv <- knitr::asis_output(rv)
598		}
599	12x	rv
600		}
601
602		# NextBestOrdinal ----
603
604		#' @description `r lifecycle::badge("experimental")`
605		#' @inheritParams knit_print.StoppingTargetProb
606		#' @rdname knit_print
607		#' @export
608		#' @method knit_print NextBestOrdinal
609		knit_print.NextBestOrdinal <- function(
610		x,
611		...,
612		tox_label = "toxicity",
613		asis = TRUE
614		) {
615	19x	assert_flag(asis)
616	17x	assert_character(tox_label, max.len = 2, any.missing = FALSE)
617
618	17x	tox_label <- h_prepare_labels(tox_label)
619	17x	rv <- paste0(
620	17x	"Based on a ",
621	17x	tox_label[1],
622	17x	" grade of ",
623	17x	x@grade,
624		": ",
625	17x	paste0(
626	17x	knit_print(x@rule, asis = asis, tox_label = tox_label, ...),
627	17x	collapse = "\n"
628		),
629	17x	"\n\n"
630		)
631
632	17x	if (asis) {
633	2x	rv <- knitr::asis_output(rv)
634		}
635	17x	rv
636		}

1		#' Format a `doseGrid` for Printing
2		#'
3		#' @param grid (`numeric`)\cr the dose grid
4		#' @param units (`character`)\cr The units in which the values in `doseGrid` are
5		#' @param fmt (`character`)\cr The format used to display values in `doseGrid`.
6		#' If `NA`, grid values are not pre-formatted
7		#' @param ... not used at present
8		#' measured. Appended to each value in `doseGrid` when `knit_print`ed. The
9		#' default, `NA`, omits the units.
10		#' @return A character string containing the formatted dose grid. If the grid
11		#' is `c(1, 2, 3)` and `units` is `"mg"`, the returned value is `"1 mg, 2 mg and 3 mg"`.
12		#' @keywords internal
13		h_get_formatted_dosegrid <- function(grid, units = NA, fmt = NA, ...) {
14	106x	assert_numeric(
15	106x	grid,
16	106x	lower = 0,
17	106x	min.len = 2,
18	106x	unique = TRUE,
19	106x	finite = TRUE,
20	106x	sorted = TRUE,
21	106x	any.missing = FALSE
22		)
23	106x	assert_character(units, len = 1)
24
25	106x	n <- length(grid)
26	106x	units <- h_prepare_units(units)
27	106x	formattedGrid <- if (is.na(fmt)) {
28	104x	as.character(grid)
29		} else {
30	2x	sprintf(fmt, grid)
31		}
32	106x	paste0(
33	106x	paste(
34	106x	lapply(
35	106x	formattedGrid[1:(n - 1)],
36	106x	paste0,
37	106x	sep = units
38		),
39	106x	collapse = ", "
40		),
41	106x	" and ",
42	106x	formattedGrid[n],
43	106x	paste0(units, ".\n\n")
44		)
45		}
46
47		#' Set Column Headers in Custom `knit_print` Methods
48		#'
49		#' This is a helper method used `knit_print` for `crmPack` classes.
50		#'
51		#' @param x (`ANY`)\cr object that will be printed
52		#' @param param (`list`)\cr A list of the `...` parameters passed to `knit_print`
53		#' @param summarise (`flag`)\cr Is the object to be summarised (default) or listed?
54		#' @return A character vector of column names.
55		#' @noRd
56		h_knit_print_set_headers <- function(x, param, summarise, ...) {
57	97x	UseMethod("h_knit_print_set_headers")
58		}
59
60		#' @description `r lifecycle::badge("experimental")`
61		#' @rdname knit_print_set_headers
62		#' @noRd
63		h_knit_print_set_headers.GeneralData <- function(x, param, summarise, ...) {
64	42x	if (!("col.names" %in% names(param))) {
65	42x	if (summarise == "none") {
66	40x	param[["col.names"]] <- c("ID", "Cohort", "Dose", "DLT?")
67	2x	} else if (summarise == "dose") {
68	1x	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
69		} else {
70	1x	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
71		}
72		}
73	42x	param
74		}
75
76		#' @description `r lifecycle::badge("experimental")`
77		#' @rdname knit_print_set_headers
78		#' @noRd
79		h_knit_print_set_headers.DataDA <- function(x, param, summarise, ...) {
80	10x	if (!("col.names" %in% names(param))) {
81	10x	if (summarise == "none") {
82	10x	param[["col.names"]] <- c(
83	10x	"ID",
84	10x	"Cohort",
85	10x	"Dose",
86	10x	"Tox",
87	10x	"U",
88	10x	"T0",
89	10x	"TMax"
90		)
91	!	} else if (summarise == "dose") {
92	!	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
93		} else {
94	!	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
95		}
96		}
97	10x	param
98		}
99
100		#' @description `r lifecycle::badge("experimental")`
101		#' @rdname knit_print_set_headers
102		#' @noRd
103		h_knit_print_set_headers.DataGrouped <- function(x, param, summarise, ...) {
104	4x	if (!("col.names" %in% names(param))) {
105	4x	if (summarise == "none") {
106	4x	param[["col.names"]] <- c("ID", "Cohort", "Dose", "Group", "Tox")
107	!	} else if (summarise == "dose") {
108	!	param[["col.names"]] <- c("Dose", "Group", "Evaluable", "With Toxicities")
109		} else {
110	!	param[["col.names"]] <- c(
111	!	"Cohort",
112	!	"Group",
113	!	"Evaluable",
114	!	"With Toxicities"
115		)
116		}
117		}
118	4x	param
119		}
120
121		#' @description `r lifecycle::badge("experimental")`
122		#' @rdname knit_print_set_headers
123		#' @noRd
124		h_knit_print_set_headers.DataParts <- function(x, param, summarise, ...) {
125	4x	if (!("col.names" %in% names(param))) {
126	4x	if (summarise == "none") {
127	4x	param[["col.names"]] <- c("ID", "Part", "Cohort", "Dose", "Tox")
128	!	} else if (summarise == "dose") {
129	!	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
130		} else {
131	!	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
132		}
133		}
134	4x	param
135		}
136
137		#' @description `r lifecycle::badge("experimental")`
138		#' @noRd
139		h_knit_print_set_headers.DataOrdinal <- function(x, param, summarise, ...) {
140	15x	if (!("col.names" %in% names(param))) {
141	15x	if (summarise == "none") {
142	15x	param[["col.names"]] <- c(
143	15x	"ID",
144	15x	"Cohort",
145	15x	"Dose",
146	15x	paste0("Cat", 0:(length(x@yCategories) - 1))
147		)
148	!	} else if (summarise == "dose") {
149	!	param[["col.names"]] <- c("Dose", "Evaluable", names(x@yCategories))
150		} else {
151	!	param[["col.names"]] <- c("Cohort", "Evaluable", names(x@yCategories))
152		}
153		}
154	15x	param
155		}
156
157		#' @description `r lifecycle::badge("experimental")`
158		#' @rdname knit_print_set_headers
159		#' @noRd
160		h_knit_print_set_headers.DataDual <- function(x, param, summarise, ...) {
161	22x	if (!("col.names" %in% names(param))) {
162	22x	if (summarise == "none") {
163	22x	param[["col.names"]] <- c("ID", "Cohort", "Dose", "Tox", "W")
164	!	} else if (summarise == "dose") {
165	!	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
166		} else {
167	!	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
168		}
169		}
170	22x	param
171		}
172
173		#' Select Columns to Print in Custom `knit_print` Methods
174		#'
175		#' This is a helper method used `knit_print` for `crmPack` classes.
176		#'
177		#' @param x (`ANY`)\cr object that will be printed
178		#' @param ... Not used at present.
179		#' @return A tidied version of `x`, containing only the selected columns.
180		#' @noRd
181		h_knit_print_select_columns <- function(x, ...) {
182	95x	UseMethod("h_knit_print_select_columns")
183		}
184
185		#' @description `r lifecycle::badge("experimental")`
186		#' @rdname knit_print_select_columns
187		#' @noRd
188		h_knit_print_select_columns.GeneralData <- function(x, ...) {
189	!	x %>%
190	!	tidy() %>%
191	!	dplyr::select("ID", "Cohort", "Dose", "Tox")
192		}
193
194		#' @description `r lifecycle::badge("experimental")`
195		#' @rdname knit_print_select_columns
196		#' @noRd
197		h_knit_print_select_columns.Data <- function(x, ...) {
198	40x	x %>%
199	40x	tidy() %>%
200	40x	dplyr::select("ID", "Cohort", "Dose", "Tox")
201		}
202
203		#' @description `r lifecycle::badge("experimental")`
204		#' @rdname knit_print_select_columns
205		#' @noRd
206		h_knit_print_select_columns.DataParts <- function(x, ...) {
207	4x	x %>%
208	4x	tidy() %>%
209	4x	dplyr::select("ID", "Part", "Cohort", "Dose", "Tox")
210		}
211
212		#' @description `r lifecycle::badge("experimental")`
213		#' @rdname knit_print_select_columns
214		#' @noRd
215		h_knit_print_select_columns.DataOrdinal <- function(x, ...) {
216	15x	x %>%
217	15x	tidy() %>%
218	15x	dplyr::select("ID", "Cohort", "Dose", tidyselect::starts_with("Cat"))
219		}
220
221		#' @description `r lifecycle::badge("experimental")`
222		#' @rdname knit_print_select_columns
223		#' @noRd
224		h_knit_print_select_columns.DataDA <- function(x, param, summarise, ...) {
225	10x	x %>%
226	10x	tidy() %>%
227	10x	dplyr::select("ID", "Cohort", "Dose", "Tox", "U", "T0", "TMax")
228		}
229
230		#' @description `r lifecycle::badge("experimental")`
231		#' @rdname knit_print_select_columns
232		#' @noRd
233		h_knit_print_select_columns.DataGrouped <- function(x, param, summarise, ...) {
234	4x	x %>%
235	4x	tidy() %>%
236	4x	dplyr::select("ID", "Cohort", "Dose", "Group", "Tox")
237		}
238
239		#' @description `r lifecycle::badge("experimental")`
240		#' @rdname knit_print_select_columns
241		#' @noRd
242		h_knit_print_select_columns.DataDual <- function(x, param, summarise, ...) {
243	22x	x %>%
244	22x	tidy() %>%
245	22x	dplyr::select("ID", "Cohort", "Dose", "Tox", "W")
246		}
247
248		#' Summarise a `Data` Object by Dose or Cohort for Display in Custom `knit_print` Methods
249		#'
250		#' This is a helper method used `knit_print` for `crmPack` classes.
251		#'
252		#' @param x (`ANY`)\cr object that will be printed
253		#' @param full_grid (`flag`)\cr Should the full grid be included or only those
254		#' doses with at least one evaluable participant?
255		#' @param ... Not used at present.
256		#' @return A tibble containing the summarised data
257		#' @noRd
258		h_knit_print_summarise <- function(x, summarise, full_grid, ...) {
259	2x	UseMethod("h_knit_print_summarise")
260		}
261
262		#' @description `r lifecycle::badge("experimental")`
263		#' @rdname knit_print_summarise
264		#' @noRd
265		h_knit_print_summarise.GeneralData <- function(x, summarise, full_grid, ...) {
266	2x	xTidy <- x %>% tidy()
267	2x	xTidy <- xTidy %>%
268	2x	dplyr::group_by(.data[[stringr::str_to_title(summarise)]]) %>%
269	2x	dplyr::summarise(
270	2x	N = dplyr::n(),
271	2x	ToxCount = sum(Tox)
272		)
273	2x	if (full_grid && summarise == "dose") {
274	!	xTidy <- xTidy %>%
275	!	tidyr::complete(
276	!	Dose = x@doseGrid,
277	!	fill = list(ToxCount = 0, N = 0)
278		)
279		}
280	2x	xTidy
281		}
282
283		#' @description `r lifecycle::badge("experimental")`
284		#' @rdname knit_print_summarise
285		#' @noRd
286		h_knit_print_summarise.DataOrdinal <- function(x, summarise, full_grid, ...) {
287	!	xTidy <- x %>% tidy()
288	!	xTidy <- xTidy %>%
289	!	dplyr::group_by(.data$Dose) %>%
290	!	dplyr::summarise(
291	!	N = dplyr::n(),
292	!	dplyr::across(tidyselect::starts_with("Cat"), sum)
293		)
294	!	if (full_grid && summarise == "dose") {
295	!	replace_list <- as.list(
296	!	c(
297	!	"N",
298	!	names(xTidy)[which(stringr::str_detect(names(xTidy), "Cat\\d+"))]
299		)
300		)
301		# Create a list whose names are the columns in which we need to replace NAs
302		# and whose values are 0
303	!	names(replace_list) <- sapply(replace_list, \(x) x)
304	!	replace_list <- lapply(replace_list, \(x) 0)
305		# Expand the tibble and do the replacement
306	!	xTidy <- tidyr::expand_grid(Dose = x@doseGrid) %>%
307	!	dplyr::left_join(xTidy, by = "Dose") %>%
308	!	tidyr::replace_na(replace_list)
309		}
310	!	xTidy
311		}
312
313		#' @description `r lifecycle::badge("experimental")`
314		#' @rdname knit_print_summarise
315		#' @noRd
316		h_knit_print_summarise.DataGrouped <- function(x, summarise, full_grid, ...) {
317	!	xTidy <- x %>% tidy()
318	!	xTidy <- xTidy %>%
319	!	dplyr::group_by(.data[[stringr::str_to_title(summarise)]], .data$Group) %>%
320	!	dplyr::summarise(
321	!	N = dplyr::n(),
322	!	ToxCount = sum(Tox)
323		)
324	!	if (full_grid && summarise == "dose") {
325	!	xTidy <- tidyr::expand_grid(
326	!	Dose = x@doseGrid,
327	!	Group = c("mono", "combo")
328		) %>%
329	!	dplyr::left_join(xTidy, by = c("Dose", "Group")) %>%
330	!	tidyr::replace_na(list(N = 0, ToxCount = 0))
331		}
332	!	xTidy
333		}
334
335		#' Print a `GeneralData` Object in a Markdown or Quarto Chunk
336		#'
337		#' @param label (`character`)\cr How to describe the participants in the trial.
338		#' See Usage Notes below.
339		#' @param full_grid (`flag`)\cr Should the full dose grid appear in the output table
340		#' or simply those doses for whom at least one evaluable participant is available?
341		#' Ignored unless `summarise == "dose"`.
342		#' @param summarise (`character`)\cr How to summarise the observed data. The default,
343		#' `"none"`, lists observed data at the participant level. `"dose"` presents
344		#' participant counts by dose and `"cohort"` by cohort.
345		#' @param summarize (`character`)\cr Synonym for `summarise`
346		#' @param format_func (`function`)\cr The function used to format the participant table.
347		#' The default applies no formatting. Obvious alternatives include `kableExtra::kable_styling`.
348		#' @param ... passed to [knitr::kable()]
349		#' @section Usage Notes:
350		#' `label` describes the trial's participants.
351		#'
352		#' It should be a character vector of length 1 or 2. If of length 2, the first
353		#' element describes a single participant and the second describes all other
354		#' situations. If of length 1, the character `s` is appended to the value
355		#' when the number of participants is not 1.
356		#' The default values of `col.names` and `caption` vary depending on the summary
357		#' requested. The default values can be overridden by passing `col.names` and
358		#' `caption` in the function call.
359		#'
360		#' @inheritParams h_get_formatted_dosegrid
361		#' @export
362		#' @method knit_print GeneralData
363		#' @rdname knit_print
364		knit_print.GeneralData <- function(
365		x,
366		...,
367		asis = TRUE,
368		label = c("participant", "participants"),
369		full_grid = FALSE,
370		summarise = c("none", "dose", "cohort"),
371		summarize = summarise,
372		units = NA,
373		format_func = h_knit_format_func
374		) {
375		# Validate
376	111x	assert_flag(asis)
377	97x	assert_flag(full_grid)
378	97x	assert_function(format_func)
379	97x	summarise <- match.arg(summarise)
380	97x	summarize <- match.arg(summarize)
381
382	97x	if (is.na(summarise) \|\| is.null(summarise)) {
383	!	summarise <- summarize
384		}
385	97x	assert_choice(summarise, c("none", "dose", "cohort"))
386		# Initialise
387	97x	label <- h_prepare_labels(label)
388	97x	param <- list(...)
389
390		# Execute
391	97x	param <- h_knit_print_set_headers(x, param, summarise, ...)
392	97x	if (summarise == "none") {
393	95x	if (!("caption" %in% names(param))) {
394	95x	param[["caption"]] <- paste("Evaluable", label[2], "to-date")
395		}
396	95x	xTidy <- h_knit_print_select_columns(x)
397		} else {
398	2x	xTidy <- h_knit_print_summarise(x, summarise, full_grid)
399	2x	if (!("caption" %in% names(param))) {
400	2x	param[["caption"]] <- paste0("Summarised by ", summarise)
401		}
402		}
403	97x	param[["x"]] <- xTidy
404	97x	rv <- if (length(x@x) > 0) {
405	32x	paste((do.call(knitr::kable, param)) %>% format_func(), collapse = "\n")
406		} else {
407	65x	paste("No", label[2], "are yet evaluable.\n\n")
408		}
409	97x	rv <- paste0(
410	97x	rv,
411	97x	paste0(
412	97x	"\n\nThe dose grid is ",
413	97x	h_get_formatted_dosegrid(
414	97x	grid = x@doseGrid,
415	97x	units = units,
416		...
417		),
418		""
419		),
420	97x	"\n\n",
421	97x	collpase = "\n"
422		)
423	97x	if (asis) {
424	18x	rv <- knitr::asis_output(rv)
425		}
426	97x	rv
427		}
428
429		#' Used to obtain expected format.
430		#' @keywords internal
431		h_knit_format_func <- function(x) {
432	37x	kableExtra::kable_styling(
433	37x	x,
434	37x	bootstrap_options = c("striped", "hover", "condensed")
435		)
436		}
437
438		#' @export
439		#' @method knit_print DataParts
440		#' @rdname knit_print
441		knit_print.DataParts <- function(
442		x,
443		...,
444		asis = TRUE,
445		label = c("participant", "participants"),
446		full_grid = FALSE,
447		summarise = c("none", "dose", "cohort"),
448		summarize = summarise,
449		units = NA,
450		format_func = h_knit_format_func
451		) {
452	6x	rv <- NextMethod()
453	4x	rv <- paste0(
454	4x	rv,
455	4x	paste0(
456	4x	"\n\nThe part 1 ladder is ",
457	4x	h_get_formatted_dosegrid(x@part1Ladder, units)
458		),
459	4x	paste0("\n\nThe next part is Part ", x@nextPart, ".\n\n")
460		)
461	4x	if (asis) {
462	2x	rv <- knitr::asis_output(rv)
463		}
464	4x	rv
465		}

1		#' @include McmcOptions-class.R
2		NULL
3
4		# size ----
5
6		## generic ----
7
8		#' Size of an Object
9		#'
10		#' @description `r lifecycle::badge("stable")`
11		#'
12		#' A method that computes the size of a given object. This can be for instance
13		#' a size of a MCMC sample, or the size of a cohort. See the help of a specific
14		#' method for more details.
15		#'
16		#' @param object (`McmcOptions` or `Samples` or `CohortSize`)\cr an object
17		#' for which the size is computed.
18		#' @param ... further arguments passed to `size` specific methods.
19		#'
20		#' @return A size of a given object.
21		#' @export
22		#'
23		setGeneric(
24		name = "size",
25		def = function(object, ...) {
26	82176x	standardGeneric("size")
27		},
28		valueClass = "integer"
29		)
30
31		## McmcOptions ----
32
33		#' @describeIn size compute the number of MCMC samples based on `McmcOptions`
34		#' object.
35		#' @aliases size-McmcOptions
36		#' @example examples/McmcOptions-methods-size.R
37		setMethod(
38		f = "size",
39		signature = signature(object = "McmcOptions"),
40		definition = function(object, ...) {
41	42165x	iterations_relative <- object@iterations - object@burnin
42	42165x	if (iterations_relative <= 0) {
43	!	return(0L)
44		}
45	42165x	as.integer(floor(iterations_relative / object@step))
46		}
47		)
48
49		# saveSample ----
50
51		## generic ----
52
53		#' Determining if this Sample Should be Saved
54		#'
55		#' @description `r lifecycle::badge("stable")`
56		#'
57		#' A method that determines if a sample from a given `iteration` should be
58		#' saved. The sample should be saved if and only if:
59		#' it is not in burn-in period and it matches the `step`.
60		#'
61		#' @param object (`McmcOptions`)\cr object based on which the answer is
62		#' determined.
63		#' @param iteration (`count`)\cr the current iteration index.
64		#' @param ... not used.
65		#' @return `TRUE` if this sample should be saved.
66		#' @export
67		#'
68		setGeneric(
69		name = "saveSample",
70		def = function(object, iteration, ...) {
71	21734x	standardGeneric("saveSample")
72		},
73		valueClass = "logical"
74		)
75
76		## McmcOptions ----
77
78		#' @describeIn saveSample determine if a sample should be saved.
79		#' @aliases saveSample-McmcOptions
80		#' @example examples/McmcOptions-methods-saveSample.R
81		setMethod(
82		f = "saveSample",
83		signature = signature(object = "McmcOptions"),
84		definition = function(object, iteration, ...) {
85	21734x	iteration_relative <- iteration - object@burnin
86	21734x	iteration_relative > 0 && ((iteration_relative %% object@step) == 0)
87		}
88		)

1		# assertions ----
2
3		#' Additional Assertions for `checkmate`
4		#'
5		#' @description `r lifecycle::badge("experimental")`
6		#'
7		#' We provide additional assertion functions that can be used together with
8		#' the `checkmate` functions. These are described in individual help pages
9		#' linked below.
10		#'
11		#' @return Depending on the function prefix.
12		#' - `assert_` functions return the object invisibly if successful, and otherwise
13		#' throw an error message.
14		#' - `check_` functions return `TRUE` if successful, otherwise a string with the
15		#' error message.
16		#' - `test_` functions just return `TRUE` or `FALSE`.
17		#'
18		#' @seealso [assert_probabilities()], [assert_probability()],
19		#' [assert_probability_range()], [assert_length()].
20		#'
21		#' @name assertions
22		NULL
23
24		# check equality ----
25
26		#' Check if All Arguments Are Equal
27		#'
28		#' @description `r lifecycle::badge("experimental")`
29		#' Elements of `...` must be numeric vectors or scalars.
30		#'
31		#' This function performs an element-by-element comparison of the first object
32		#' provided in `...` with every other object in `...` and returns `TRUE` if all
33		#' comparisons are equal within a given tolerance and `FALSE` otherwise.
34		#'
35		#' @param ... (`numeric`)\cr vectors to be compared.
36		#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
37		#' judging equality.
38		#'
39		#' @note If there are any missing or infinite values in `...`, this function
40		#' returns `FALSE`, regardless of the values of other elements in `...`.
41		#'
42		#' @note If elements in `...` are not all of the same length, `FALSE` is returned.
43		#'
44		#' @return `TRUE` if all element-by-element differences are less than `tolerance`
45		#' in magnitude, `FALSE` otherwise.
46		#' @seealso [`assertions`] for more details.
47		#'
48		#' @export
49		#' @examples
50		#' check_equal(1:2, 1:2) # TRUE
51		#' check_equal(1:2, 2:3) # "Not all equal"
52		#' check_equal(Inf, Inf) # "Not all equal"
53		#' check_equal(0.01, 0.02) # "Not all equal"
54		#' check_equal(0.01, 0.02, tol = 0.05) # TRUE
55		#' check_equal(1, c(1, 1)) # "Not all equal"
56		check_equal <- function(..., tol = sqrt(.Machine$double.eps)) {
57	14x	dot_args <- list(...)
58
59	14x	sapply(dot_args, assert_numeric)
60
61	14x	tmp <- sapply(dot_args, length)
62	14x	if (min(tmp) != max(tmp)) {
63	2x	return("Not all of same length")
64		}
65	12x	if (any(sapply(dot_args, is.na))) {
66	2x	return("Some entries NA")
67		}
68	10x	if (any(sapply(dot_args, is.infinite))) {
69	2x	return("Not all entries finite")
70		}
71	8x	if (!all(sapply(dot_args, test_numeric))) {
72	!	return("Not all numeric")
73		}
74
75	8x	all_ok <- test_true(
76	8x	all(
77	8x	sapply(
78	8x	2:length(dot_args),
79	8x	function(z) abs(dot_args[[1]] - dot_args[[z]]) < tol
80		)
81		)
82		)
83	8x	if (all_ok) {
84	4x	return(TRUE)
85		}
86	4x	"Not all equal"
87		}
88
89		#' Assert That All Arguments Are Equal
90		#'
91		#' @description `r lifecycle::badge("experimental")`
92		#' Elements of `...` must be numeric vectors or scalars.
93		#'
94		#' This function performs an element-by-element comparison of the first object
95		#' provided in `...` with every other object in `...` and throws an error if they
96		#' are not.
97		#'
98		#' @param ... (`numeric`)\cr vectors to be compared
99		#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
100		#' judging equality
101		#'
102		#' @note If there are any missing or infinite values in `...`, this function
103		#' throws an error, regardless of the values of other elements in `...`.
104		#'
105		#' @note If elements in `...` are not all of the same length, an error is thrown.
106		#'
107		#' @return `list(...)`, invisibly.
108		#' @seealso [`assertions`] for more details.
109		#' @inheritParams checkmate::assert_numeric
110		#'
111		#' @export
112		#' @rdname check_equal
113		#' @examples
114		#' assert_equal(1:2, 1:2) # no error
115		#' assert_equal(0.01, 0.02, tol = 0.05) # no error
116		# nolint start
117		assert_equal <- function(
118		...,
119		tol = sqrt(.Machine$double.eps),
120		.var.name = vname(x),
121		add = NULL
122		) {
123		# assert_equal <- makeAssertionFunction(check_equal) fails with error "Error
124		# in `checkmate::makeAssertion(..., res, .var.name, add)`: unused argument
125		# (add)", possibly because of the use of ... in check_equal.
126	7x	res <- check_equal(..., tol = tol)
127	7x	makeAssertion(list(...), res, .var.name, add)
128		}
129		# nolint end
130
131		# assert_probabilities ----
132
133		#' Check if an argument is a probability vector
134		#'
135		#' @description `r lifecycle::badge("stable")`
136		#'
137		#' Check if every element in a given numerical vector or matrix represents a
138		#' probability, that is a number within (0, 1) interval, that can optionally be
139		#' closed at any side.
140		#'
141		#' @note If there are any missing or non-finite values in `x`, this function
142		#' returns `FALSE`, regardless of the values of other elements in `x`.
143		#'
144		#' @param x (`numeric`)\cr vector or matrix with numerical values to check.
145		#' @param bounds_closed (`logical`)\cr should bounds be closed? This can be a
146		#' scalar or vector of length two. If it is a scalar, then its value applies
147		#' equally to lower bound \eqn{0} and upper bound \eqn{1}. If this is a vector
148		#' with two flags, the first flag corresponds to the lower bound \eqn{0}
149		#' only, and the second to the upper bound \eqn{1} only.
150		#' @inheritParams checkmate::check_numeric
151		#'
152		#' @return `TRUE` if successful, otherwise a string with the error message.
153		#'
154		#' @seealso [`assertions`] for more details.
155		#'
156		#' @export
157		#' @examples
158		#' x <- c(0, 0.2, 0.1, 0.3, 1)
159		#' check_probabilities(x)
160		#' check_probabilities(x, bounds_closed = FALSE)
161		#' check_probabilities(x, bounds_closed = c(FALSE, TRUE))
162		check_probabilities <- function(
163		x,
164		bounds_closed = TRUE,
165		len = NULL,
166		unique = FALSE,
167		sorted = FALSE
168		) {
169	10556x	assert_numeric(x)
170	10555x	assert_logical(bounds_closed, min.len = 1, max.len = 2, any.missing = FALSE)
171	10555x	assert_number(len, null.ok = TRUE)
172	10555x	assert_flag(sorted)
173
174	10555x	result <- check_numeric(
175	10555x	x,
176	10555x	finite = TRUE,
177	10555x	any.missing = FALSE,
178	10555x	len = len,
179	10555x	unique = unique,
180	10555x	sorted = sorted
181		)
182
183	10555x	if (isTRUE(result)) {
184	10476x	in_bounds <- all(h_in_range(
185	10476x	x,
186	10476x	range = c(0L, 1L),
187	10476x	bounds_closed = bounds_closed
188		))
189	10476x	if (!in_bounds) {
190	142x	result <- paste(
191	142x	"Probability must be within",
192	142x	ifelse(bounds_closed[1], "[0,", "(0,"),
193	142x	ifelse(tail(bounds_closed, 1), "1]", "1)"),
194	142x	"bounds but it is not"
195		)
196		}
197		}
198
199	10555x	result
200		}
201
202		#' @rdname check_probabilities
203		#' @inheritParams check_probabilities
204		#' @export
205		assert_probabilities <- makeAssertionFunction(check_probabilities)
206
207		#' @rdname check_probabilities
208		#' @inheritParams check_probabilities
209		#' @export
210		test_probabilities <- makeTestFunction(check_probabilities)
211
212		#' @rdname check_probabilities
213		#' @inheritParams check_probabilities
214		#' @export
215		expect_probabilities <- makeExpectationFunction(check_probabilities)
216
217		# assert_probability ----
218
219		#' Check if an argument is a single probability value
220		#'
221		#' @description `r lifecycle::badge("stable")`
222		#'
223		#' Check if a given value represents a probability, that is a number within
224		#' (0, 1) interval, that can optionally be closed at any side.
225		#'
226		#' @param x (`number`)\cr a single value to check.
227		#' @inheritParams check_probabilities
228		#'
229		#' @return `TRUE` if successful, otherwise a string with the error message.
230		#'
231		#' @seealso [`assertions`] for more details.
232		#'
233		#' @export
234		#' @examples
235		#' check_probability(0.5)
236		#' check_probability(0, bounds_closed = FALSE)
237		#' check_probability(0, bounds_closed = c(FALSE, TRUE))
238		check_probability <- function(x, bounds_closed = TRUE) {
239	5651x	check_probabilities(x = x, bounds_closed = bounds_closed, len = 1)
240		}
241
242		#' @rdname check_probability
243		#' @inheritParams check_probability
244		#' @export
245		assert_probability <- makeAssertionFunction(check_probability)
246
247		#' @rdname check_probability
248		#' @inheritParams check_probability
249		#' @export
250		test_probability <- makeTestFunction(check_probability)
251
252		#' @rdname check_probability
253		#' @inheritParams check_probability
254		#' @export
255		expect_probability <- makeExpectationFunction(check_probability)
256
257		# assert_probability_range ----
258
259		#' Check if an argument is a probability range
260		#'
261		#' @description `r lifecycle::badge("stable")`
262		#'
263		#' Check if a given numerical interval represents a probability range, that is
264		#' a sub-interval of (0, 1) interval, that can optionally be closed at any side.
265		#'
266		#' @param x (`number`)\cr an interval to check.
267		#' @inheritParams check_probabilities
268		#'
269		#' @return `TRUE` if successful, otherwise a string with the error message.
270		#'
271		#' @seealso [`assertions`] for more details.
272		#'
273		#' @export
274		#' @examples
275		#' x <- c(0, 0.2)
276		#' check_probability_range(x)
277		#' check_probability_range(rev(x))
278		#' check_probability_range(x, bounds_closed = FALSE)
279		#' check_probability_range(x, bounds_closed = c(FALSE, TRUE))
280		check_probability_range <- function(x, bounds_closed = TRUE) {
281	792x	check_probabilities(
282	792x	x = x,
283	792x	bounds_closed = bounds_closed,
284	792x	len = 2,
285	792x	sorted = TRUE
286		)
287		}
288
289		#' @rdname check_probability_range
290		#' @inheritParams check_probability_range
291		#' @export
292		assert_probability_range <- makeAssertionFunction(check_probability_range)
293
294		#' @rdname check_probability_range
295		#' @inheritParams check_probability_range
296		#' @export
297		test_probability_range <- makeTestFunction(check_probability_range)
298
299		#' @rdname check_probability_range
300		#' @inheritParams check_probability_range
301		#' @export
302		expect_probability_range <- makeExpectationFunction(check_probability_range)
303
304		# assert_length ----
305
306		#' Check if vectors are of compatible lengths
307		#'
308		#' @description `r lifecycle::badge("stable")`
309		#'
310		#' Two vectors are of compatible size if and only if: \cr
311		#' 1. At least one vector has size 1 \cr
312		#' 2. or both vectors are of the same size. \cr
313		#'
314		#' @param x (`any`)\cr the first vector, any object for which [length()]
315		#' function is defined.
316		#' @param len (`count`)\cr the length of the second vector.
317		#' @inheritParams checkmate::check_numeric
318		#'
319		#' @return `TRUE` if successful, otherwise a string with the error message.
320		#'
321		#' @seealso [`assertions`] for more details.
322		#'
323		#' @export
324		#' @examples
325		#' check_length(1:5, 1)
326		#' check_length(1:5, 6)
327		#' check_length(1:5, 5)
328		#' check_length(10, 1)
329		#' check_length(10, 9)
330		check_length <- function(x, len) {
331	42067x	x_len <- length(x)
332	42067x	assert_true(x_len >= 1L)
333	42066x	assert_count(len)
334
335	42062x	if (x_len == 1L \|\| len == 1L \|\| x_len == len) {
336	42033x	TRUE
337		} else {
338	29x	paste(
339	29x	"x is of length",
340	29x	x_len,
341	29x	"which is not allowed; the allowed lengths are: 1 or",
342	29x	len,
343	29x	collapse = ""
344		)
345		}
346		}
347
348		#' @rdname check_length
349		#' @inheritParams check_length
350		#' @export
351		assert_length <- makeAssertionFunction(check_length)
352
353		#' @rdname check_length
354		#' @inheritParams check_length
355		#' @export
356		test_length <- makeTestFunction(check_length)
357
358		# assert_range ----
359
360		#' Check that an argument is a numerical range
361		#'
362		#' @description `r lifecycle::badge("stable")`
363		#'
364		#' An argument `x` is a numerical range if and only if (all conditions must be met):
365		#' 1. Is an object of type: `integer` or `double`.
366		#' 2. Is a vector or length two such that the value of the first number is not
367		#' less than the second number. Equalness is allowed if and only if `unique` flag
368		#' is set to `TRUE`.
369		#' 3. Lower bound of the interval is greater than or equal to `lower` and
370		#' upper bound of the interval is less than or equal to `upper`.
371		#' 4. It contains only finite (given that `finite` is `TRUE`) and non-missing values.
372		#'
373		#' @inheritParams checkmate::check_numeric
374		#'
375		#' @return `TRUE` if successful, otherwise a string with the error message.
376		#'
377		#' @seealso [`assertions`] for more details.
378		#'
379		#' @export
380		#' @examples
381		#' check_range(c(1, 5))
382		#' check_range(c(-5, 1))
383		#' check_range(c(4, 1))
384		#' check_range(c(1, 1))
385		#' check_range(c(1, 1), unique = FALSE)
386		#' check_range(1:3)
387		check_range <- function(
388		x,
389		lower = -Inf,
390		upper = Inf,
391		finite = FALSE,
392		unique = TRUE
393		) {
394	93x	assert_number(lower)
395	92x	assert_number(upper)
396	91x	assert_flag(finite)
397	90x	assert_flag(unique)
398
399	89x	result <- check_numeric(
400	89x	x,
401	89x	lower = lower,
402	89x	upper = upper,
403	89x	finite = finite,
404	89x	any.missing = FALSE,
405	89x	len = 2,
406	89x	unique = unique,
407	89x	sorted = TRUE
408		)
409
410	89x	if (!isTRUE(result)) {
411	24x	result <- paste("x must be a valid numerical range.", result)
412		}
413	89x	result
414		}
415
416		#' @rdname check_range
417		#' @inheritParams check_range
418		#' @export
419		assert_range <- makeAssertionFunction(check_range)
420
421		#' @rdname check_range
422		#' @inheritParams check_range
423		#' @export
424		test_range <- makeTestFunction(check_range)
425
426		#' @rdname check_range
427		#' @inheritParams check_range
428		#' @export
429		expect_range <- makeExpectationFunction(check_range)
430
431		# assert_format ----
432
433		#' Check that an argument is a valid format specification
434		#'
435		#' @description `r lifecycle::badge("stable")`
436		#'
437		#' @inheritParams checkmate::check_numeric
438		#'
439		#' @return `TRUE` if successful, otherwise a string with the error message.
440		#'
441		#' @seealso [`assertions`] for more details.
442		#'
443		#' @export
444		#' @examples
445		#' check_format("%5.2f")
446		check_format <- function(x, len = NULL, min.len = NULL, max.len = NULL) {
447	262x	assert_number(len, lower = 1, null.ok = TRUE)
448	262x	assert_number(min.len, lower = 1, null.ok = TRUE)
449	262x	assert_number(max.len, lower = 1, null.ok = TRUE)
450
451	262x	result <- check_character(
452	262x	x,
453	262x	len = len,
454	262x	min.len = min.len,
455	262x	max.len = max.len,
456	262x	any.missing = FALSE,
457		# https://stackoverflow.com/questions/446285/validate-sprintf-format-from-input-field-with-regex
458	262x	pattern = "%(?:\\d+\\$)?[+-]?(?:[ 0]\|'.{1})?-?\\d*(?:\\.\\d+)?[bcdeEufFgGosxX]",
459		)
460
461	262x	if (!isTRUE(result)) {
462	!	result <- paste("x must be a valid format specifier.", result)
463		}
464	262x	result
465		}
466
467		#' @rdname check_format
468		#' @inheritParams check_format
469		#' @export
470		assert_format <- makeAssertionFunction(check_format)
471
472		#' @rdname check_format
473		#' @inheritParams check_format
474		#' @export
475		test_format <- makeTestFunction(check_format)
476
477		#' @rdname check_format
478		#' @inheritParams check_format
479		#' @export
480		expect_format <- makeExpectationFunction(check_format)

1		#' Helper Function to Blind Plot Data
2		#'
3		#' @param df (`GeneralData`)\cr The data to be blinded
4		#' @param blind (`flag`)\cr Should the data be blinded?
5		#' @param has_placebo (`flag`)\cr Does the data contain a placebo dose?
6		#' @param pbo_dose (`positive_number`)\cr The dose to be taken as placebo.
7		#' Ignored if `has_placebo` is `FALSE`
8		#' @returns The blinded data
9		h_blind_plot_data <- function(df, blind, has_placebo, pbo_dose) {
10	19x	if (blind) {
11		# This is to blind the data.
12		# For each cohort, all DLTs are assigned to the first subjects in the cohort.
13		# In addition, the placebo (if any) is set to the active dose level for that
14		# cohort.
15		# Notice: dapply reorders records of df according to the lexicographic order
16		# of cohort.
17	9x	df <- dapply(df, f = ~cohort, FUN = function(coh) {
18	30x	coh$toxicity <- sort(coh$toxicity, decreasing = TRUE)
19	30x	coh$dose <- max(coh$dose)
20	30x	coh
21		})
22	10x	} else if (has_placebo) {
23		# Placebo will be plotted at y = 0 level.
24	8x	df$dose[df$dose == pbo_dose] <- 0
25		}
26	19x	df
27		}
28
29		# h_plot_data_df ----
30
31		## generic ----
32
33		#' Helper Function for the Plot Method of subclasses of [`GeneralData`]
34		#'
35		#' @description `r lifecycle::badge("experimental")`
36		#'
37		#' A method that transforms [`GeneralData`] objects into a `tibble` suitable for
38		#' plotting with `ggplot2` methods
39		#'
40		#' @param data (`GeneralData`)\cr object from which data is extracted and converted
41		#' into a data frame.
42		#' @param ... further arguments passed to class-specific methods.
43		#' @return `data.frame` containing columns for patient, cohort, dose and toxicity grade
44		#' @aliases h_plot_data_df
45		#'
46		setGeneric(
47		name = "h_plot_data_df",
48		def = function(data, ...) standardGeneric("h_plot_data_df"),
49		valueClass = "data.frame"
50		)
51
52		# Data ----
53
54		#' Helper Function for the Plot Method of [`Data`]
55		#'
56		#' @param data (`Data`)\cr object from which data is extracted and converted
57		#' into a data frame.
58		#' @param blind (`flag`)\cr should data be blinded?
59		#' If `TRUE`, then for each cohort, all DLTs are assigned to the first
60		#' subjects in the cohort. In addition, the placebo (if any) is set to the
61		#' active dose level for that cohort.
62		#' @param legend (`flag`)\cr Display the legend for the toxicity categories
63		#' @param ... further arguments passed to `data.frame` constructor.
64		#' It can be e.g. an extra `column_name = value` pair based on a slot
65		#' from `x` (which in this case might be a subclass of `Data`)
66		#' which does not appear in `Data`.
67		#' @return A `data.frame` object with columns patient, ID, cohort, dose and
68		#' toxicity.
69		#' @describeIn h_plot_data_df method for [`Data`].
70		setMethod(
71		f = "h_plot_data_df",
72		signature = signature(data = "Data"),
73		definition = function(data, blind = FALSE, legend = TRUE, ...) {
74	17x	df <- data.frame(
75	17x	patient = seq_along(data@x),
76	17x	ID = paste(" ", data@ID),
77	17x	cohort = data@cohort,
78	17x	dose = data@x,
79	17x	toxicity = ifelse(data@y == 1, "Yes", "No"),
80		...
81		)
82	17x	df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
83	17x	df
84		}
85		)
86
87		# DataOrdinal ----
88
89		#' Helper Function for the Plot Method of [`DataOrdinal`]
90		#'
91		#' @describeIn h_plot_data_df Class specific method for [`DataOrdinal`]
92		setMethod(
93		f = "h_plot_data_df",
94		signature = signature(data = "DataOrdinal"),
95		definition = function(data, blind = FALSE, legend = TRUE, ...) {
96	2x	df <- data.frame(
97	2x	patient = seq_along(data@x),
98	2x	ID = paste(" ", data@ID),
99	2x	cohort = data@cohort,
100	2x	dose = data@x,
101	2x	toxicity = names(data@yCategories)[1 + data@y],
102		...
103		)
104	2x	df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
105	2x	df
106		}
107		)
108
109
110		# h_plot_data_dataordinal
111
112		## Data ----
113
114		#' Helper Function for the Plot Method of the Data and DataOrdinal Classes
115		#'
116		#' @description `r lifecycle::badge("stable")`
117		#'
118		#' A method that creates a plot for [`Data`] and [`DataOrdinal`] objects.
119		#'
120		#' @note The default values of `tox_shapes` and `tox_labels` result in DLTs
121		#' being displayed as red triangles and other responses as black circles.
122		#' @return The [`ggplot2`] object.
123		#'
124		#' @rdname plot-Data
125		h_plot_data_dataordinal <- function(
126		x,
127		blind = FALSE,
128		legend = TRUE,
129		tox_labels = c(Yes = "red", No = "black"),
130		tox_shapes = c(Yes = 17L, No = 16L),
131		...
132		) {
133	10x	assert_flag(blind)
134	10x	assert_flag(legend)
135	10x	assert_character(tox_labels, any.missing = FALSE, unique = TRUE)
136	10x	assert_integer(tox_shapes, any.missing = FALSE, unique = TRUE)
137	10x	assert_true(length(tox_shapes) == length(tox_labels))
138	10x	assert_subset(x@y, as.integer(0:(length(tox_shapes) - 1)))
139	10x	if (x@nObs == 0L) {
140	!	return()
141		}
142	10x	df <- h_plot_data_df(x, blind, ...)
143
144	10x	p <- ggplot(df, aes(x = patient, y = dose)) +
145	10x	geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +
146	10x	scale_colour_manual(
147	10x	name = "Toxicity",
148	10x	values = tox_labels,
149	10x	breaks = names(tox_labels),
150	10x	guide = guide_legend(reverse = TRUE)
151		) +
152	10x	scale_shape_manual(
153	10x	name = "Toxicity",
154	10x	values = tox_shapes,
155	10x	breaks = names(tox_shapes),
156	10x	guide = guide_legend(reverse = TRUE)
157		) +
158	10x	scale_x_continuous(breaks = df$patient, minor_breaks = NULL) +
159	10x	scale_y_continuous(
160	10x	breaks = sort(unique(c(0, df$dose))),
161	10x	minor_breaks = NULL,
162	10x	limits = c(0, max(df$dose) * 1.1)
163		) +
164	10x	xlab("Patient") +
165	10x	ylab("Dose Level")
166
167	10x	p <- p + h_plot_data_cohort_lines(df$cohort, placebo = x@placebo)
168
169	10x	if (!blind) {
170	4x	p <- p +
171	4x	geom_text(
172	4x	aes(label = ID, size = 2),
173	4x	data = df,
174	4x	hjust = 0,
175	4x	vjust = 0.5,
176	4x	angle = 90,
177	4x	colour = "black",
178	4x	show.legend = FALSE
179		)
180		}
181
182	10x	if (!legend) {
183	6x	p <- p + theme(legend.position = "none")
184		}
185
186	10x	p
187		}
188
189		#' Helper Function Containing Common Functionality
190		#'
191		#' Used by `dose_grid_range-Data` and `dose_grid_range-DataOrdinal`
192		#' @param object (`Data` or `DataOrdinal`)\cr the object for which the dose grid
193		#' range is required
194		#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
195		#'
196		h_obtain_dose_grid_range <- function(object, ignore_placebo) {
197	168x	assert_flag(ignore_placebo)
198
199	166x	dose_grid <- if (ignore_placebo && object@placebo && object@nGrid >= 1) {
200	12x	object@doseGrid[-1]
201		} else {
202	154x	object@doseGrid
203		}
204
205	166x	if (length(dose_grid) == 0L) {
206	10x	c(-Inf, Inf)
207		} else {
208	156x	range(dose_grid)
209		}
210		}
211
212		#' Convert a Ordinal Data to the Equivalent Binary Data for a Specific
213		#' Grade
214		#'
215		#' @description `r lifecycle::badge("experimental")`
216		#'
217		#' A simple helper function that takes a [`DataOrdinal`] object and an
218		#' integer grade and converts them to the equivalent `Data` object.
219		#'
220		#' @param data_ord (`DataOrdinal`)\cr the `DataOrdinal` object to covert
221		#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
222		#' is required.
223		#' @return A [`Data`] object.
224		#'
225		#' @export
226		h_convert_ordinal_data <- function(data_ord, grade) {
227		# Validate
228	27x	assert_integer(grade, len = 1, lower = 1)
229	27x	assert_class(data_ord, "DataOrdinal")
230		# Execute
231	27x	Data(
232	27x	ID = data_ord@ID,
233	27x	cohort = data_ord@cohort,
234	27x	x = data_ord@x,
235	27x	y = as.integer(data_ord@y >= grade),
236	27x	doseGrid = data_ord@doseGrid,
237	27x	nGrid = data_ord@nGrid,
238	27x	xLevel = data_ord@xLevel,
239	27x	placebo = data_ord@placebo
240		)
241		}

1		#' @include helpers_knitr_CohortSize.R
2
3		# Increments ----
4
5		#' Render a `IncrementsRelative` Object
6		#'
7		#' @description `r lifecycle::badge("experimental")`
8		#' @inherit knit_print.CohortSizeConst return
9		#' @param ... passed to [knitr::kable()]
10		#' @inheritParams knit_print.CohortSizeConst
11		#' @section Usage Notes:
12		#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
13		#' of `caption` is `"Defined by highest dose administered so far"`. These
14		#' values can be overridden by passing `col.names` and `caption` in the function
15		#' call.
16		#' @export
17		#' @method knit_print IncrementsRelative
18		#' @rdname knit_print
19		knit_print.IncrementsRelative <- function(x, ..., asis = TRUE) {
20	66x	assert_flag(asis)
21
22	64x	param <- list(...)
23	64x	if (!("col.names" %in% names(param))) {
24	64x	param[["col.names"]] <- c("Min", "Max", "Increment")
25		}
26	64x	if (!("caption" %in% names(param))) {
27	64x	param[["caption"]] <- "Defined by highest dose administered so far"
28		}
29	64x	x <- tidy(x)
30	64x	param[["x"]] <- x
31	64x	rv <- kableExtra::add_header_above(
32	64x	do.call(knitr::kable, param),
33	64x	c("Dose" = 2, " " = 1)
34		)
35	64x	rv <- paste0(rv, "\n\n")
36
37	64x	if (asis) {
38	6x	rv <- knitr::asis_output(rv)
39		}
40	64x	rv
41		}
42
43		#' Render an `IncrementsRelativeDLT` object
44		#'
45		#' @description `r lifecycle::badge("experimental")`
46		#' @inherit knit_print.CohortSizeConst return
47		#' @param ... passed to [knitr::kable()]
48		#' @inheritParams knit_print.CohortSizeConst
49		#' @section Usage Notes:
50		#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
51		#' of `caption` is `"Defined by number of DLTs reported so far"`. These values
52		#' can be overridden by passing `col.names` and `caption` in the function call.
53		#' @export
54		#' @method knit_print IncrementsRelativeDLT
55		#' @rdname knit_print
56		knit_print.IncrementsRelativeDLT <- function(x, ..., asis = TRUE) {
57	10x	assert_flag(asis)
58
59	8x	param <- list(...)
60	8x	if (!("col.names" %in% names(param))) {
61	8x	param[["col.names"]] <- c("Min", "Max", "Increment")
62		}
63	8x	if (!("caption" %in% names(param))) {
64	8x	param[["caption"]] <- "Defined by number of DLTs reported so far"
65		}
66
67	8x	param[["x"]] <- tidy(x)
68	8x	rv <- kableExtra::add_header_above(
69	8x	do.call(knitr::kable, param),
70	8x	c("No DLTs" = 2, " " = 1)
71		)
72	8x	rv <- paste0(rv, "\n\n")
73
74	8x	if (asis) {
75	4x	rv <- knitr::asis_output(rv)
76		}
77	8x	rv
78		}
79
80		#' Render an `IncrementsDoseLevels` object
81		#'
82		#' @description `r lifecycle::badge("experimental")`
83		#' @inherit knit_print.CohortSizeConst return
84		#' @inheritParams knit_print.CohortSizeConst
85		#' @export
86		#' @rdname knit_print
87		#' @method knit_print IncrementsDoseLevels
88		knit_print.IncrementsDoseLevels <- function(x, ..., asis = TRUE) {
89	6x	assert_flag(asis)
90
91	4x	rv <- paste0(
92	4x	"The maximum increment between cohorts is ",
93	4x	x@levels,
94	4x	ifelse(x@levels == 1, " level", " levels"),
95	4x	" relative to the ",
96	4x	ifelse(
97	4x	x@basis_level == "last",
98	4x	"dose used in the previous cohort.",
99	4x	"highest dose used so far."
100		),
101	4x	"\n\n"
102		)
103
104	4x	if (asis) {
105	2x	rv <- knitr::asis_output(rv)
106		}
107	4x	rv
108		}
109
110		#' Render an `IncrementsHSRBeta` object
111		#'
112		#' @description `r lifecycle::badge("experimental")`
113		#' @inherit knit_print.CohortSizeConst return
114		#' @inheritParams knit_print.CohortSizeConst
115		#' @export
116		#' @method knit_print IncrementsHSRBeta
117		#' @rdname knit_print
118		knit_print.IncrementsHSRBeta <- function(x, ..., asis = TRUE) {
119	6x	assert_flag(asis)
120
121	4x	rv <- paste0(
122	4x	"The maximum increment is defined by a hard safety rule, independent of the CRM model, ",
123	4x	" and based on a beta(",
124	4x	x@a,
125		", ",
126	4x	x@b,
127		") ",
128	4x	"prior with a target toxicity rate of ",
129	4x	x@target,
130	4x	" and a probability threshold of ",
131	4x	x@prob,
132	4x	".\n\n"
133		)
134
135	4x	if (asis) {
136	2x	rv <- knitr::asis_output(rv)
137		}
138	4x	rv
139		}
140
141		#' Render an `IncrementsMin` object
142		#'
143		#' @description `r lifecycle::badge("experimental")`
144		#' @inherit knit_print.CohortSizeConst return
145		#' @param ... passed through to the `knit_print` methods of the constituent
146		#' rules
147		#' @inheritParams knit_print.CohortSizeConst
148		#' @export
149		#' @method knit_print IncrementsMin
150		#' @rdname knit_print
151		knit_print.IncrementsMin <- function(x, ..., asis = TRUE) {
152	6x	assert_flag(asis)
153
154	4x	rv <- paste0(
155	4x	"The minimum of the increments defined in the following rules:",
156	4x	paste0(
157	4x	lapply(
158	4x	x@increments_list,
159	4x	function(x, ...) {
160	8x	knit_print(x, asis = asis, ...)
161		}
162		),
163	4x	collapse = "\n"
164		),
165	4x	"\n\n",
166	4x	paste = "\n"
167		)
168
169	4x	if (asis) {
170	2x	rv <- knitr::asis_output(rv)
171		}
172	4x	rv
173		}
174
175		#' Render an `IncrementsOrdinal` object
176		#' @inherit knit_print.CohortSizeConst return
177		#' @param ... passed through to the `knit_print` method of the standard rule
178		#' @inheritParams knit_print.CohortSizeConst
179		#' @export
180		#' @method knit_print IncrementsOrdinal
181		#' @rdname knit_print
182		knit_print.IncrementsOrdinal <- function(x, ..., asis = TRUE) {
183	10x	assert_flag(asis)
184
185	8x	rv <- paste0(
186	8x	"Based on a toxicity grade of ",
187	8x	x@grade,
188		": ",
189	8x	paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n"),
190	8x	"\n\n",
191	8x	paste = "\n"
192		)
193
194	8x	if (asis) {
195	2x	rv <- knitr::asis_output(rv)
196		}
197	8x	rv
198		}
199
200		#' Render an `IncrementsRelativeParts` object
201		#'
202		#' @inherit knit_print.CohortSizeConst return
203		#' @param tox_label (`character`)\cr The word used to describe toxicities. See
204		#' Usage Notes below.
205		#' @inheritParams knit_print.CohortSizeConst
206		#' @section Usage Notes:
207		#' `label` defines how toxicities are described.
208		#'
209		#' It should be a character vector of length 1 or 2. If of length 2, the first
210		#' element describes a single toxicity and the second describes all other
211		#' toxicity counts. If of length 1, the character `s` is appended to the value
212		#' describing a single toxicity.
213		#'
214		#' @export
215		#' @method knit_print IncrementsRelativeParts
216		#' @rdname knit_print
217		knit_print.IncrementsRelativeParts <- function(
218		x,
219		...,
220		asis = TRUE,
221		tox_label = c("toxicity", "toxicities")
222		) {
223	7x	assert_flag(asis)
224
225	5x	tox_label <- h_prepare_labels(tox_label)
226	5x	rv <- paste0(
227	5x	"The maximum increment in Part 1 is defined by the `part1Ladder` slot of ",
228	5x	"the associated `DataParts` object.\n\n",
229	5x	"If no ",
230	5x	tox_label[2],
231	5x	" are reported in Part 1, the starting dose for Part 2 ",
232	5x	"will be ",
233	5x	ifelse(
234	5x	x@clean_start == 0,
235	5x	"the highest dose used in Part 1.\n\n",
236	5x	paste0(
237	5x	x@clean_start,
238	5x	ifelse(abs(x@clean_start) == 1, " dose ", " doses "),
239	5x	ifelse(x@clean_start < 0, "below ", "above "),
240	5x	"the highest dose used in Part 1.\n\n"
241		)
242		),
243	5x	"If one or more ",
244	5x	tox_label[2],
245	5x	" are reported in Part 1, the starting dose for Part 2 ",
246	5x	"will be ",
247	5x	ifelse(
248	5x	x@dlt_start == 0,
249	5x	"the highest dose used in Part 1.\n\n",
250	5x	paste0(
251	5x	abs(x@dlt_start),
252	5x	ifelse(abs(x@dlt_start) == 1, " dose ", " doses "),
253	5x	ifelse(x@dlt_start < 0, "below ", "above "),
254	5x	"the highest dose used in Part 1.\n\n"
255		)
256		),
257	5x	"Once Part 2 has started, the maximum increment in dose levels will be based ",
258	5x	"on the number of ",
259	5x	tox_label[2],
260	5x	" reported so far, as described in the ",
261	5x	"following table:"
262		)
263
264	5x	param <- list(...)
265	5x	if (!("col.names" %in% names(param))) {
266	5x	param[["col.names"]] <- c("Lower", "Upper", "Increment")
267		}
268	5x	if (!("caption" %in% names(param))) {
269	5x	param[["caption"]] <- paste0(
270	5x	"Defined by the number of ",
271	5x	tox_label[2],
272	5x	" reported so far"
273		)
274		}
275	5x	header <- c(2, 1)
276	5x	headerLabel <- tox_label[2]
277	5x	substr(headerLabel, 1, 1) <- toupper(substr(headerLabel, 1, 1))
278	5x	names(header) <- c(headerLabel, " ")
279	5x	param[["x"]] <- tibble(
280	5x	intervals = x@intervals
281		) %>%
282	5x	h_range_to_minmax(intervals) %>%
283	5x	tibble::add_column(increments = c(0, x@increments))
284	5x	d_tab <- kableExtra::add_header_above(
285	5x	do.call(knitr::kable, param),
286	5x	header
287		)
288	5x	rv <- paste(rv, d_tab, "\n\n")
289	5x	if (asis) {
290	3x	rv <- knitr::asis_output(rv)
291		}
292	5x	rv
293		}
294
295		#' Render an `IncrementsRelativeDLTCurrent` object
296		#'
297		#' @description `r lifecycle::badge("experimental")`
298		#' @inherit knit_print.CohortSizeConst return
299		#' @param tox_label (`character`)\cr The word used to describe toxicities. See
300		#' Usage Notes below.
301		#' @param ... passed to [knitr::kable()]
302		#' @inheritParams knit_print.CohortSizeConst
303		#' @section Usage Notes:
304		#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
305		#' of `caption` is `"Defined by number of DLTs in the current cohort"`. These values
306		#' can be overridden by passing `col.names` and `caption` in the function call.
307		#'
308		#' `tox_label` defines how toxicities are described.
309		#'
310		#' It should be a character vector of length 1 or 2. If of length 2, the first
311		#' element describes a single toxicity and the second describes all other
312		#' toxicity counts. If of length 1, the character `s` is appended to the value
313		#' describing a single toxicity.
314		#'
315		#' @export
316		#' @method knit_print IncrementsRelativeDLTCurrent
317		#' @rdname knit_print
318		knit_print.IncrementsRelativeDLTCurrent <- function(
319		x,
320		...,
321		asis = TRUE,
322		tox_label = c("DLT", "DLTs")
323		) {
324	6x	assert_flag(asis)
325	4x	assert_character(tox_label, min.len = 1, max.len = 2, any.missing = FALSE)
326
327	4x	if (length(tox_label) == 1) {
328	!	tox_label[2] <- paste0(tox_label[1], "s")
329		}
330
331	4x	param <- list(...)
332	4x	if (!("col.names" %in% names(param))) {
333	4x	param[["col.names"]] <- c("Min", "Max", "Increment")
334		}
335	4x	if (!("caption" %in% names(param))) {
336	4x	param[["caption"]] <- paste0(
337	4x	"Defined by number of ",
338	4x	tox_label[2],
339	4x	" reported in the current cohort"
340		)
341		}
342	4x	param[["x"]] <- tidy(x)
343	4x	header_text <- c(2, 1)
344	4x	names(header_text) <- c(paste0("No ", tox_label[2]), " ")
345	4x	rv <- kableExtra::add_header_above(
346	4x	do.call(knitr::kable, param),
347	4x	header_text
348		)
349	4x	rv <- paste0(rv, "\n\n")
350
351	4x	if (asis) {
352	2x	rv <- knitr::asis_output(rv)
353		}
354	4x	rv
355		}

1		# GeneralSimulations ----
2
3		#' Internal Helper Functions for Validation of [`GeneralSimulations`] Objects
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' These functions are only used internally to validate the format of an input
8		#' [`GeneralSimulations`] or inherited classes and therefore not exported.
9		#'
10		#' @name v_general_simulations
11		#' @param object (`GeneralSimulations`)\cr object to validate.
12		#' @return A `character` vector with the validation failure messages,
13		#' or `TRUE` in case validation passes.
14		NULL
15
16		#' @describeIn v_general_simulations validates that the [`GeneralSimulations`] object
17		#' contains valid `data` object and valid `dose` simulations.
18
19		v_general_simulations <- function(object) {
20	!	v <- Validate()
21
22	!	nSims <- length(object@data)
23
24	!	v$check(
25	!	all(sapply(object@data, is, "Data")),
26	!	"all data elements must be Data objects"
27		)
28	!	v$check(
29	!	identical(length(object@doses), nSims),
30	!	"doses must have same length as the data list"
31		)
32
33	!	v$result()
34		}
35
36		#' @describeIn v_general_simulations validates that the [`Simulations`] object
37		#' contains valid object `fit`, `stop_reasons`, `stop_report`, and
38		#' `additional_stats` compared to the general class [`GeneralSimulations`].
39		#'
40		v_simulations <- function(object) {
41	!	v <- Validate()
42
43	!	nSims <- length(object@data)
44
45	!	v$check(
46	!	identical(length(object@fit), nSims),
47	!	"fit must have same length as data"
48		)
49	!	v$check(
50	!	identical(length(object@stop_reasons), nSims),
51	!	"stop_reasons must have same length as data"
52		)
53
54	!	v$check(
55	!	checkmate::test_matrix(
56	!	object@stop_report,
57	!	mode = "logical",
58	!	nrows = nSims,
59	!	min.cols = 1,
60	!	any.missing = FALSE
61		),
62	!	"stop_report must be a matrix of mode logical in which the number of rows
63	!	equals the number of simulations and which must not contain any missing values"
64		)
65
66	!	v$result()
67		}
68
69		#' @describeIn v_general_simulations validates that the [`DualSimulations`] object and
70		#' capture the dose-biomarker `fits`, and the `sigma2W` and `rho` estimates.
71		#'
72		v_dual_simulations <- function(object) {
73	!	v <- Validate()
74
75	!	nSims <- length(object@data)
76
77	!	v$check(
78	!	identical(length(object@fit_biomarker), nSims),
79	!	"fit_biomarker list has to have same length as data"
80		)
81	!	v$check(
82	!	identical(length(object@rho_est), nSims),
83	!	"rho_est vector has to have same length as data"
84		)
85	!	v$check(
86	!	identical(length(object@sigma2w_est), nSims),
87	!	"sigma2w_est has to have same length as data"
88		)
89
90	!	v$result()
91		}
92
93		# PseudoSimulations ----
94
95		#' Internal Helper Functions for Validation of [`PseudoSimulations`] Objects
96		#'
97		#' @description `r lifecycle::badge("stable")`
98		#'
99		#' These functions are only used internally to validate the format of an input
100		#' [`PseudoSimulations`] or inherited classes and therefore not exported.
101		#'
102		#' @name v_pseudo_simulations
103		#' @param object (`PseudoSimulations`)\cr object to validate.
104		#' @return A `character` vector with the validation failure messages,
105		#' or `TRUE` in case validation passes.
106		NULL
107
108		#' @describeIn v_pseudo_simulations validates that the [`PseudoSimulations`] object
109		#' contains valid `fit`, `FinalTDtargetEndOfTrialEstimates` ,
110		#' `FinalTDtargetDuringTrialAtDoseGrid`,`FinalTDtargetEndOfTrialAtDoseGrid` ,
111		#' `FinalTDEOTCIs`, `FinalTDEOTRatios`, `FinalCIs`, `FinalRatios`,
112		#' object and valid `stopReasons` simulations.
113
114		v_pseudo_simulations <- function(object) {
115	!	v <- Validate()
116
117	!	nSims <- length(object@data)
118	!	v$check(
119	!	identical(length(object@stop_reasons), nSims),
120	!	"stopReasons must have same length as data"
121		)
122
123	!	v$result()
124		}
125
126		#' @describeIn v_pseudo_simulations validates that the [`PseudoDualSimulations`] object
127		#' contains valid `fit_eff`, `final_gstar_estimates` , `final_gstar_at_dose_grid`,
128		#' `final_gstar_cis` , `final_gstar_ratios`, `final_optimal_dose`, `final_optimal_dose_at_dose_grid`
129		#' object and valid `sigma2_est` simulations.
130
131		v_pseudo_dual_simulations <- function(object) {
132	!	v <- Validate()
133	!	nSims <- length(object@data)
134	!	v$check(
135	!	identical(length(object@sigma2_est), nSims),
136	!	"sigma2_est has to have same length as data"
137		)
138	!	v$result()
139		}
140
141		#' @describeIn v_pseudo_simulations validates that the [`PseudoDualFlexiSimulations`]
142		#' object contains valid `sigma2_beta_w_est` vector of the final posterior mean
143		#' sigma2betaW estimates.`FinalGstarEstimates` , `FinalGstarAtDoseGrid`,
144		#'
145		v_pseudo_dual_flex_simulations <- function(object) {
146	!	v <- Validate()
147	!	nSims <- length(object@data)
148	!	v$check(
149	!	identical(length(object@sigma2_beta_w_est), nSims),
150	!	"sigma2_beta_w_est has to have same length as data"
151		)
152	!	v$result()
153		}
154
155		#' @describeIn v_general_simulations validates that the [`DASimulations`] object
156		#' contains valid `trialduration` the vector of trial duration values for all
157		#' simulations.
158
159		v_da_simulations <- function(object) {
160	!	v <- Validate()
161
162	!	nSims <- length(object@data)
163
164	!	v$check(
165	!	identical(length(object@trialduration), nSims),
166	!	"trialduration vector has to have same length as data"
167		)
168
169	!	v$result()
170		}

1		#' @include helpers.R
2		NULL
3
4		#' Appending a Dummy Number for Selected Slots in Data
5		#'
6		#' @description `r lifecycle::badge("experimental")`
7		#'
8		#' A helper function that appends a dummy value to a given slots in [`GeneralData`]
9		#' class object, if and only if the total number of observations (as indicated
10		#' by `object@nObs`) equals to `1`. Otherwise, the `object` is not changed.
11		#'
12		#' @note The main motivation behind this function is related to the `JAGS`.
13		#' If there is only one observation, the data is not passed correctly to
14		#' `JAGS`, i.e. e.g. `x` and `y` are treated like scalars in the data file.
15		#' Therefore it is necessary to add dummy values to the vectors in this case
16		#' As we don't change the number of observations (`nObs`), this addition of
17		#' zeros doesn't affect the results of `JAGS` computations.
18		#'
19		#' @param object (`GeneralData`)\cr object into which dummy values will be added.
20		#' @param where (`character`)\cr names of slots in `object` to which a `dummy`
21		#' number will be appended.
22		#' @param dummy (`number`)\cr a dummy number that will be appended to selected
23		#' slots in `object`. Default to `0`.
24		#'
25		#' @return A [`GeneralData`] object with slots updated with dummy number.
26		#'
27		#' @export
28		#' @example examples/helpers-jags_add_dummy.R
29		#'
30		h_jags_add_dummy <- function(object, where, dummy = 0) {
31	397x	assert_class(object, "GeneralData")
32	397x	assert_character(where)
33	397x	assert_subset(where, slotNames(object))
34	396x	assert_number(dummy)
35
36	396x	if (object@nObs == 1L) {
37	6x	for (i in where) {
38		# Add dummy value and preserve the class.
39	13x	slot(object, i) <- as(c(slot(object, i), dummy), class(slot(object, i)))
40		}
41		}
42	396x	object
43		}
44
45		#' Joining `JAGS` Models
46		#'
47		#' @description `r lifecycle::badge("stable")`
48		#'
49		#' This helper function joins two JAGS models in the way that the body of the
50		#' second model is appended to the body of the first model (in this order).
51		#' After that, the first, body-extended model is returned. The arguments of
52		#' `model1`, `model2` model functions (if any) are not combined in any way.
53		#'
54		#' @note `model1` and `model2` functions must have a multi-expression
55		#' body, i.e. braced expression(s). Environments or any attributes of the
56		#' function bodies are not preserved in any way after joining.
57		#'
58		#' @param model1 (`function`)\cr the first model to join.
59		#' @param model2 (`function`)\cr the second model to join.
60		#'
61		#' @return joined models.
62		#'
63		#' @export
64		#'
65		h_jags_join_models <- function(model1, model2) {
66	782x	assert_function(model1)
67	782x	assert_function(model2)
68	782x	assert_class(body(model1), "{")
69	781x	assert_class(body(model2), "{")
70
71		# This workaround is needed to avoid bugs related to covr-injected code.
72	781x	if (h_covr_active()) {
73	781x	body(model2) <- h_covr_detrace(body(model2))
74		}
75
76	781x	body2 <- as.list(body(model2))
77	781x	if (length(body2) >= 2) {
78	780x	body1 <- as.list(body(model1))
79	780x	body(model1) <- as.call(c(body1, body2[-1]))
80		}
81	781x	model1
82		}
83
84
85		#' Setting Initial Values for `JAGS` Model Parameters
86		#'
87		#' @description `r lifecycle::badge("experimental")`
88		#'
89		#' A simple helper function that prepares an object for `inits` argument of
90		#' [rjags::jags.model()], which is invoked by [mcmc()] method. The `inits`
91		#' argument specifies initial values for model parameters.
92		#'
93		#' @param model (`GeneralModel`)\cr an input model.
94		#' @param data (`GeneralData`)\cr an input data.
95		#'
96		#' @return A `list` of starting values for parameters required to be initialized
97		#' in the MCMC `JAGS `sampler.
98		#'
99		#' @export
100		#' @example examples/helpers-jags_get_model_inits.R
101		#'
102		h_jags_get_model_inits <- function(model, data) {
103	390x	assert_class(model, "GeneralModel")
104	390x	assert_class(data, "GeneralData")
105
106	390x	inits <- do.call(model@init, h_slots(data, formalArgs(model@init)))
107	390x	assert_list(inits)
108	389x	inits[sapply(inits, length) > 0L]
109		}
110
111		#' Getting Data for `JAGS`
112		#'
113		#' @description `r lifecycle::badge("experimental")`
114		#'
115		#' A simple helper function that prepares an object for `data` argument of
116		#' [rjags::jags.model()], which is invoked by [mcmc()] method.
117		#'
118		#' @param model (`GeneralModel`)\cr an input model.
119		#' @param data (`GeneralData`)\cr an input data.
120		#' @param from_prior (`flag`)\cr sample from the prior only? In this case
121		#' data will not be appended to the output, i.e. only the variables required
122		#' by the `model@priormodel` model will be returned in data.
123		#'
124		#' @export
125		#' @example examples/helpers-jags_get_data.R
126		#'
127		h_jags_get_data <- function(model, data, from_prior) {
128	393x	assert_class(model, "GeneralModel")
129	393x	assert_class(data, "GeneralData")
130	393x	assert_flag(from_prior)
131
132		# 1) Extract variables from `data` as required by `modelspecs`.
133	393x	ms_args_names <- formalArgs(model@modelspecs)
134	393x	ms_args <- if ("from_prior" %in% ms_args_names) {
135	362x	c(
136	362x	h_slots(data, setdiff(ms_args_names, "from_prior")),
137	362x	list(from_prior = from_prior)
138		)
139		} else {
140	31x	h_slots(data, ms_args_names)
141		}
142	393x	modelspecs <- do.call(model@modelspecs, ms_args)
143	393x	assert_list(modelspecs)
144
145		# 2) Extract variables from `data` as required by `datanames`.
146	392x	datanames <- if (from_prior) {
147	41x	model@datanames_prior
148		} else {
149	351x	union(model@datanames, model@datanames_prior)
150		}
151
152		# Add dummy to ensure that e.g. `x` and `y` in `data` won't be treated as
153		# scalars by `JAGS` if `data@nObs == 1`, which leads to failures.
154	392x	add_where <- setdiff(
155	392x	datanames,
156	392x	c("nObs", "nGrid", "nObsshare", "yshare", "xshare", "Tmax")
157		)
158	392x	data <- h_jags_add_dummy(data, where = add_where)
159
160	392x	data_model <- h_slots(data, datanames)
161	392x	c(data_model, modelspecs)
162		}
163
164		#' Writing JAGS Model to a File
165		#'
166		#' @description `r lifecycle::badge("stable")`
167		#'
168		#' This function converts a R function with JAGS model into a text and then
169		#' writes it into a given file. During the "model into text" conversion, the
170		#' format of numbers of which absolute value is less than `0.001` or greater
171		#' than `10000` is changed. These numbers will be converted into scientific
172		#' format with specified number of significant digits using [formatC()]
173		#' function.
174		#'
175		#' @note JAGS syntax allows truncation specification like `dnorm(...) I(...)`,
176		#' which is illegal in R. To overcome this incompatibility, use dummy operator
177		#' `\%_\%` before `I(...)`, i.e. `dnorm(...) \%_\% I(...)` in the model's
178		#' code. This dummy operator `\%_\%` will be removed just before saving the
179		#' JAGS code into a file.
180		#' Due to technical issues related to conversion of numbers to scientific
181		#' format, it is required that the body of a model function does not contain
182		#' `TEMP_NUM_PREF_` or `_TEMP_NUM_SUF` character constants in its body.
183		#'
184		#' @param model (`function`)\cr function containing the JAGS model.
185		#' @param file (`string` or `NULL`)\cr the name of the file (including the
186		#' optional path) where the model will be saved. If `NULL`, the file will be
187		#' created in a `R_crmPack` folder placed under temporary directory indicated
188		#' by [tempdir()] function.
189		#' @param digits (`count`)\cr a desired number of significant digits for
190		#' for numbers used in JAGS input, see [formatC()].
191		#' @return The name of the file where the model was saved.
192		#'
193		#' @export
194		#' @example examples/helpers-jags_write_model.R
195		#'
196		h_jags_write_model <- function(model, file = NULL, digits = 5) {
197	419x	assert_function(model)
198	419x	assert_count(digits)
199
200		# This workaround is needed to avoid bugs related to covr-injected code.
201	419x	if (h_covr_active()) {
202	419x	body(model) <- h_covr_detrace(body(model))
203		}
204
205	419x	if (!is.null(file)) {
206	1x	assert_path_for_output(file)
207		} else {
208	418x	dir <- file.path(tempdir(), "R_crmPack")
209		# Don't warn, as the temp dir often exists (which is OK).
210	418x	dir.create(dir, showWarnings = FALSE)
211	418x	file <- tempfile(
212	418x	pattern = "jags_model_fun",
213	418x	tmpdir = dir,
214	418x	fileext = ".txt"
215		)
216		}
217
218		# Replace scientific notation.
219	419x	model_sci_replaced <- h_rapply(
220	419x	x = body(model),
221	419x	fun = h_format_number,
222	419x	classes = c("integer", "numeric"),
223	419x	digits = digits,
224	419x	prefix = "TEMP_NUM_PREF_",
225	419x	suffix = "_TEMP_NUM_SUF"
226		)
227		# Transform `model` body into character vector.
228	419x	model_text <- deparse(model_sci_replaced, control = NULL)
229	419x	model_text <- gsub("\"TEMP_NUM_PREF_\|_TEMP_NUM_SUF\"", "", model_text)
230	419x	model_text <- gsub("%_% ", "", model_text)
231	419x	model_text <- c("model", model_text)
232
233	419x	log_trace("Writting JAGS model function into: %s", file)
234	419x	writeLines(model_text, con = file)
235	419x	file
236		}
237
238		#' Extracting Samples from `JAGS` `mcarray` Object
239		#'
240		#' @description `r lifecycle::badge("stable")`
241		#'
242		#' A simple helper function that extracts a sample from
243		#' [`rjags::mcarray.object`] S3 class object. The [`rjags::mcarray.object`]
244		#' object is used by the [rjags::jags.samples()] function to represent MCMC
245		#' output from a `JAGS` model.
246		#'
247		#' @param x an [`rjags::mcarray.object`] object.
248		#'
249		#' @export
250		#'
251		h_jags_extract_samples <- function(x) {
252	1091x	assert_class(x, "mcarray")
253
254	1091x	x <- x[,, 1L]
255		# In case that there are multiple parameters in a node.
256	1091x	if (is.matrix(x)) {
257	168x	x <- t(x)
258		}
259	1091x	x
260		}

1		#' Convert a Samples Object from an ordinal Model to the Equivalent Samples Object
2		#' from a Binary Model
3		#'
4		#' @description `r lifecycle::badge("experimental")`
5		#'
6		#' A simple helper function that converts a [`Samples`] object from the fit of an
7		#' ordinal CRM model to that which would have been obtained from fitting a binary
8		#' CRM model for toxicities of a specified grade to the same observed data.
9		#'
10		#' @param obj (`Samples`)\cr the `Samples` object to covert
11		#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
12		#' is required.
13		#' @return A [`Samples`] object.
14		#'
15		#' @export
16		h_convert_ordinal_samples <- function(obj, grade) {
17		# Validate
18	27x	assert_integer(grade, len = 1, lower = 1)
19	25x	assert_class(obj, "Samples")
20	24x	assert_subset(c(paste0("alpha", 1:grade), "beta"), names(obj@data))
21		# Execute
22	23x	d <- list(
23	23x	"alpha0" = obj@data[[paste0("alpha", grade)]],
24	23x	"alpha1" = obj@data$beta
25		)
26	23x	Samples(data = d, options = obj@options)
27		}

1		#' Update [`DualEndpoint`] class model components with regard to biomarker
2		#' regression variance.
3		#'
4		#' @description `r lifecycle::badge("stable")`
5		#'
6		#' A simple helper function that takes [`DualEndpoint`] model existing components
7		#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
8		#' to biomarker regression variance `sigma2W`.
9		#'
10		#' @param use_fixed (`flag`)\cr indicates whether a fixed value for the biomarker
11		#' regression variance `sigma2W` should be used or not. If `sigma2W` is not
12		#' supposed to be a fixed value, a prior distribution from the Inverse-Gamma
13		#' distribution will be used. See the details below, under `sigma2W` argument.
14		#' @param sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
15		#' Inverse-Gamma distribution parameters, i.e. vector with two elements named
16		#' `a` and `b`.
17		#' @param comp (`list`)\cr a named list with model components that will be updated.
18		#' The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
19		#' definitions of the components, see [`GeneralModel`] class.
20		#' The `modelspecs` and `init` components on `comp` list are specified up to
21		#' the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
22		#' functions. These bodies are simply a lists itself.
23		#'
24		#' @return `list` with updated model components.
25		#'
26		#' @export
27		h_model_dual_endpoint_sigma2W <- function(
28		use_fixed, # nolintr
29		sigma2W,
30		comp
31		) {
32	210x	if (use_fixed) {
33	114x	assert_number(sigma2W, lower = 0 + .Machine$double.xmin, finite = TRUE)
34	112x	comp$modelspecs$precW <- 1 / sigma2W
35		} else {
36	96x	assert_true(h_test_named_numeric(sigma2W, permutation.of = c("a", "b")))
37	95x	comp$priormodel <- h_jags_join_models(
38	95x	comp$priormodel,
39	95x	function() {
40	!	precW ~ dgamma(precWa, precWb)
41		}
42		)
43	95x	comp$modelspecs$precWa <- sigma2W[["a"]]
44	95x	comp$modelspecs$precWb <- sigma2W[["b"]]
45	95x	comp$init$precW <- 1
46	95x	comp$sample <- c(comp$sample, "precW")
47		}
48	207x	comp
49		}
50
51		#' Update [`DualEndpoint`] class model components with regard to DLT and biomarker
52		#' correlation.
53		#'
54		#' @description `r lifecycle::badge("stable")`
55		#'
56		#' A simple helper function that takes [`DualEndpoint`] model existing components
57		#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
58		#' DLT and biomarker correlation `rho`.
59		#'
60		#' @param use_fixed (`flag`)\cr indicates whether a fixed value for DLT and
61		#' biomarker correlation `rho` should be used or not. If `rho` is not supposed
62		#' to be a fixed value, a prior distribution from the scaled Beta family will
63		#' be used. See the details below, under `rho` argument.
64		#' @param rho (`numeric`)\cr DLT and biomarker correlation. It must be either a
65		#' fixed value (between `-1` and `1`), or a named vector with two elements,
66		#' named `a` and `b` for the Beta prior on the transformation
67		#' `kappa = (rho + 1) / 2`, which is in `(0, 1)`. For example, `a = 1, b = 1`
68		#' leads to a uniform prior on `rho`.
69		#' @param comp (`list`)\cr a named list with model components that will be updated.
70		#' The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
71		#' definitions of the components, see [`GeneralModel`] class.
72		#' The `modelspecs` and `init` components on `comp` list are specified up to
73		#' the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
74		#' functions. These bodies are simply a lists itself.
75		#'
76		#' @return A `list` with updated model components.
77		#'
78		#' @export
79		h_model_dual_endpoint_rho <- function(use_fixed, rho, comp) {
80	211x	rmin <- .Machine$double.xmin
81	211x	if (use_fixed) {
82	115x	assert_number(rho, lower = -1 + rmin, upper = 1 - rmin)
83	112x	comp$modelspecs$rho <- rho
84		} else {
85	96x	assert_true(h_test_named_numeric(rho, permutation.of = c("a", "b")))
86	95x	comp$priormodel <- h_jags_join_models(
87	95x	comp$priormodel,
88	95x	function() {
89	!	kappa ~ dbeta(rhoa, rhob)
90	!	rho <- 2 * kappa - 1
91		}
92		)
93	95x	comp$modelspecs$rhoa <- rho[["a"]]
94	95x	comp$modelspecs$rhob <- rho[["b"]]
95	95x	comp$init$kappa <- 0.5
96	95x	comp$sample <- c(comp$sample, "rho")
97		}
98	207x	comp
99		}
100
101		#' Update certain components of [`DualEndpoint`] model with regard to prior variance
102		#' factor of the random walk.
103		#'
104		#' @description `r lifecycle::badge("stable")`
105		#'
106		#' A simple helper function that takes [`DualEndpoint`] object and updates
107		#' `priormodel`, `modelspecs`, `init`, `sample` slots according to the random walk
108		#' variance.
109		#'
110		#' @param use_fixed (`flag`)\cr indicates whether a fixed value for
111		#' `sigma2betaW` should be used or not. If `sigma2betaW` is not supposed
112		#' to be a fixed value, a prior distribution from the Inverse-Gamma distribution
113		#' will be used. See the details below, under `sigma2betaW` argument.
114		#' @param sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
115		#' prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
116		#' parameters, i.e. vector with two elements named `a` and `b`.
117		#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
118		#'
119		#' @return A [`DualEndpoint`] model with updated `priormodel`, `modelspecs`,
120		#' `init`, `sample` slots.
121		#'
122		#' @seealso [`DualEndpointRW`].
123		#' @export
124		h_model_dual_endpoint_sigma2betaW <- function(
125		use_fixed, # nolintr
126		sigma2betaW,
127		de
128		) {
129	61x	modelspecs <- de@modelspecs
130	61x	init <- de@init
131
132	61x	if (use_fixed) {
133	49x	assert_number(sigma2betaW, lower = 0 + .Machine$double.xmin, finite = TRUE)
134	47x	ms <- list(precBetaW = 1 / sigma2betaW)
135		} else {
136	12x	assert_true(h_test_named_numeric(sigma2betaW, permutation.of = c("a", "b")))
137		# gamma prior for random walk precision.
138	11x	de@priormodel <- h_jags_join_models(
139	11x	de@priormodel,
140	11x	function() {
141	!	precBetaW ~ dgamma(precBetaWa, precBetaWb)
142		}
143		)
144	11x	ms <- list(precBetaWa = sigma2betaW[["a"]], precBetaWb = sigma2betaW[["b"]])
145	11x	de@init <- function(y) {
146	10x	c(init(y), list(precBetaW = 1))
147		}
148	11x	de@sample <- c(de@sample, "precBetaW")
149		}
150	58x	de@modelspecs <- function(from_prior) {
151	41x	c(modelspecs(from_prior), ms)
152		}
153	58x	de
154		}
155
156		#' Update certain components of [`DualEndpoint`] model with regard to parameters
157		#' of the function that models dose-biomarker relationship defined in the
158		#' [`DualEndpointBeta`] class.
159		#'
160		#' @description `r lifecycle::badge("stable")`
161		#'
162		#' A simple helper function that takes [`DualEndpoint`] object and updates
163		#' `use_fixed`, `priormodel`, `modelspecs`, `init`, `sample` slots with regard
164		#' to a given parameter of the dose-biomarker relationship \eqn{f(x)} defined in
165		#' the [`DualEndpointBeta`] class. This update solely depends on whether a given
166		#' parameter's value `param` is a fixed-valued scalar or two-elements numeric
167		#' vector. In the later case, it is assumed that `param` represents two
168		#' parameters of a probability distribution that will be used in `priormodel`
169		#' function to generate values for the `param_name` parameter of \eqn{f(x)}.
170		#' See the help page for [`DualEndpointBeta`] class for more details.
171		#'
172		#' @param param (`numeric`)\cr the value of a given `param_name` parameter of
173		#' the dose-biomarker relationship function \eqn{f(x)}. Either a fixed-valued
174		#' scalar or vector with two elements that are the parameters of a probability
175		#' distribution that will be used in `priormodel` function to generate values
176		#' for the `param_name` parameter of \eqn{f(x)}.
177		#' @param param_name (`string`)\cr the name of the parameter of \eqn{f(x)},
178		#' whose value depends on `param`.
179		#' @param param_suffix (`character`)\cr the two suffixes to be appended to
180		#' the elements of `param_name` and then used when updating `modelspecs`.
181		#' The value of this argument is ignored when `param` is a scalar.
182		#' @param priormodel (`function` or `NULL`)\cr a function representing the
183		#' `JAGS` prior specification that will be appended to existing
184		#' `de@priormodel` specification if `param` is not a scalar. Otherwise,
185		#' `de@priormodel` remains unchanged.
186		#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
187		#'
188		#' @return A [`DualEndpoint`] model with updated `use_fixed`, `priormodel`,
189		#' `modelspecs`, `init`, `sample` slots.
190		#'
191		#' @export
192		h_model_dual_endpoint_beta <- function(
193		param,
194		param_name,
195		param_suffix = c("_low", "_high"),
196		priormodel = NULL,
197		de
198		) {
199	179x	assert_numeric(param, min.len = 1, max.len = 2, any.missing = FALSE)
200	178x	assert_string(param_name)
201	177x	assert_class(de, "DualEndpoint")
202
203	177x	use_fixed <- setNames(test_number(param), param_name)
204	177x	modelspecs <- de@modelspecs
205	177x	init <- de@init
206
207	177x	if (use_fixed) {
208	81x	ms <- setNames(list(param), param_name)
209		} else {
210	96x	assert_character(param_suffix, len = 2, unique = TRUE, any.missing = FALSE)
211	95x	assert_function(priormodel)
212	94x	param_name2 <- paste0(param_name, param_suffix)
213
214	94x	de@priormodel <- h_jags_join_models(
215	94x	de@priormodel,
216	94x	priormodel
217		)
218	94x	ms <- setNames(list(param[1], param[2]), param_name2)
219	94x	de@init <- function(y) {
220	21x	c(init(y), setNames(list(mean(param)), param_name))
221		}
222	94x	de@sample <- c(de@sample, param_name)
223		}
224	175x	de@modelspecs <- function(from_prior) {
225	60x	c(modelspecs(from_prior), ms)
226		}
227	175x	de@use_fixed <- c(de@use_fixed, use_fixed)
228	175x	de
229		}
230
231		#' Convert an ordinal CRM model to the Equivalent Binary CRM Model for a Specific
232		#' Grade
233		#'
234		#' @description `r lifecycle::badge("experimental")`
235		#'
236		#' A simple helper function that takes a [`LogisticLogNormalOrdinal`] and an
237		#' integer grade and converts them to the equivalent `LogisticLogNormal` model.
238		#'
239		#' @param x (`LogisticLogNormalOrdinal`)\cr the `LogisticLogNormalOrdinal`
240		#' model to covert
241		#' @param grade (`integer`)\cr the toxicity grade for which the equivalent model
242		#' is required.
243		#' @return A [`LogisticLogNormal`] model.
244		#'
245		#' @export
246		h_convert_ordinal_model <- function(x, grade) {
247		# Validate
248	21x	assert_integer(grade, len = 1, lower = 1)
249	21x	assert_class(x, "LogisticLogNormalOrdinal")
250		# Execute
251	21x	LogisticLogNormal(
252	21x	mean = x@params@mean[-grade],
253	21x	cov = x@params@cov[-grade, -grade],
254	21x	ref_dose = x@ref_dose
255		)
256		}

1		#' Apply a Function to Subsets of Data Frame.
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' `dapply` splits the data `df` into the subsets defined by `f`,
6		#' and applies function `FUN` to each of the subset.
7		#' All the results are row-binded and returned as `data.frame` object.
8		#'
9		#' @param df (`data frame`)\cr data set to be divided into groups.
10		#' @param f (`factor` or `formula` or `list`)\cr a factor in the sense that
11		#' `as.factor(f)` defines the grouping, or a `list` of such factors in which
12		#' case their interaction is used for the grouping. `f` can also be a formula
13		#' of the form `~ g1 + ... + gk` to split by the interaction of the variables
14		#' `g1, ..., gk`. This parameter is passed directly into [split()] function.
15		#' @param FUN (`function`)\cr the function to be applied to each subset of `df`
16		#' defined by `f`.
17		#' @param ... parameters passed to [lapply()], which is used when applying a
18		#' function `FUN` over groups defined by `f`.
19		#'
20		#' @return The [`data.frame`] object with results from `FUN`.
21		#'
22		#' @export
23		#' @example examples/utils-dapply.R
24		#'
25		dapply <- function(df, f, FUN, ...) {
26	11x	assert_data_frame(df)
27
28	11x	list_df <- split(df, f = f)
29	11x	list_df <- lapply(list_df, FUN, ...)
30	11x	df2 <- do.call(rbind, list_df)
31	11x	rownames(df2) <- NULL
32	11x	df2
33		}

1		# tidy ----
2
3		## generic ----
4
5		#' Tidying `CrmPackClass` objects
6		#'
7		#' @description `r lifecycle::badge("experimental")`
8		#'
9		#' In the spirit of the `broom` package, provide a method to convert a
10		#' `CrmPackClass` object to a (list of) tibbles.
11		#'
12		#' @param x (`CrmPackClass`)\cr the object to be tidied.
13		#' @param ... potentially used by class-specific methods
14		#'
15		#' @return A (list of) tibble(s) representing the object in tidy form.
16		#'
17		#' @export
18		#'
19		setGeneric(
20		name = "tidy",
21		def = function(x, ...) {
22	921x	standardGeneric("tidy")
23		}
24		)
25
26		## CrmPackClass ----
27
28		#' Tidy a `CrmPackClass` Object
29		#'
30		#' Following the principles of the `broom` package, convert a `CrmPackClass`
31		#' object to a (list of) tibbles. This is a basic, default representation.
32		#'
33		#' @param x (`CrmPackClass`)\cr the object to be tidied.
34		#' @param ... potentially used by class-specific methods.
35		#' @rdname tidy
36		#' @aliases tidy-CrmPackClass
37		#' @keywords methods
38		#' @example examples/CrmPackClass-method-tidy.R
39		#'
40		#' @export
41		setMethod(
42		f = "tidy",
43		signature = signature(x = "CrmPackClass"),
44		definition = function(x, ...) {
45	436x	rv <- h_tidy_all_slots(x) %>% h_tidy_class(x)
46	436x	if (length(rv) == 1) {
47	77x	rv[[names(rv)[1]]] %>% h_tidy_class(x)
48		} else {
49	359x	rv
50		}
51		}
52		)

1		#' Check That Labels Are Valid and Useful
2		#'
3		#' A vector of labels is valid and useful if it is of length 2, of type character
4		#' and its values are distinct.
5		#'
6		#' If `x` is a scalar, a second element is added, whose value is the value of the
7		#' scalar with "s" appended. If `x` is `"toxicity"`, the plural is handled appropriately.
8		#'
9		#' @param x (`character`)\cr The vector to be checked
10		#' @keywords internal
11		#' @return a character vector of length 2 whose values are distinct
12		h_prepare_labels <- function(x) {
13	602x	assert_character(
14	602x	x,
15	602x	min.len = 1,
16	602x	max.len = 2,
17	602x	any.missing = FALSE,
18	602x	unique = TRUE
19		)
20
21	600x	if (length(x) == 1) {
22	391x	if (x == "toxicity") {
23	165x	x <- c("toxicity", "toxicities")
24		} else {
25	226x	x[2] <- paste0(x[1], "s")
26		}
27		}
28	600x	x
29		}
30
31		#' Append Units to a Numeric Dose
32		#'
33		#' @param units (`character`)\cr the units to be displayed
34		#' @keywords internal
35		#' @return if `units` is `NA`, then `NA`. Otherwise, `units`, ensuring that exactly
36		#' one space precedes the first non-whitespace character
37		h_prepare_units <- function(units = NA) {
38	222x	assert_character(units, len = 1)
39
40	222x	ifelse(
41	222x	is.na(units),
42		"",
43	222x	paste0(" ", stringr::str_trim(units, "left"))
44		)
45		}

1		#' @include McmcOptions-class.R
2		#' @include Samples-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# Samples ----
7
8		## class ----
9
10		#' `Samples`
11		#'
12		#' @description `r lifecycle::badge("stable")`
13		#'
14		#' [`Samples`] is the class to store the MCMC samples.
15		#'
16		#' @slot data (`list`)\cr MCMC samples of the parameter. Each entry in this list
17		#' must be a vector (in case of a scalar parameter) or matrix (in case of a
18		#' vector-valued parameter) with samples.
19		#' In case of matrix, every row is a separate sample, while columns correspond
20		#' to the dimension of the parameter.
21		#' @slot options (`McmcOptions`)\cr MCMC options that were used to generate the
22		#' samples.
23		#'
24		#' @aliases Samples
25		#' @export
26		#'
27		.Samples <- setClass(
28		Class = "Samples",
29		slots = c(
30		data = "list",
31		options = "McmcOptions"
32		),
33		prototype = prototype(
34		data = list(),
35		options = McmcOptions()
36		),
37		contains = "CrmPackClass",
38		validity = v_samples
39		)
40
41		## constructor ----
42
43		#' @rdname Samples-class
44		#'
45		#' @param data see slot definition.
46		#' @param options see slot definition.
47		#'
48		#' @export
49		#' @example examples/Samples-class.R
50		#'
51		Samples <- function(data, options) {
52	2623x	new("Samples", data = data, options = options)
53		}
54
55		## default constructor ----
56
57		#' @rdname Samples-class
58		#' @note Typically, end users will not use the `.DefaultSamples()` function.
59		#' @export
60		.DefaultSamples <- function() {
61	5x	mcmc(
62	5x	data = .DefaultData(),
63	5x	model = .DefaultLogisticLogNormal(),
64	5x	options = .DefaultMcmcOptions()
65		)
66		}

1		#' Helpers for stripping expressions of `covr`-inserted trace code
2		#'
3		#' Workarounds to allow the package to continue to work while running `covr`
4		#' with minimal changes to the package code.
5		#'
6		#' @details
7		#' When using `covr`, the source code for package objects are modified to add
8		#' callbacks for each expression to log its execution. Given an arbitrary
9		#' expression, such as:
10		#'
11		#' expr
12		#'
13		#' The code will be modified before executing any package code to look like:
14		#'
15		#' if (TRUE) {
16		#' covr:::count("file.R:1:2:3:4:5:6:7:8")
17		#' expr
18		#' }
19		#'
20		#' These functions are used for stripping expressions of this code so that the
21		#' package continues to work as intended while running tests as part of running
22		#' `covr` to calculate package coverage.
23		#'
24		#' This method is non-exhaustive, covering only a subset of `covr`'s tracing
25		#' behaviors necessary for this package.
26		#'
27		#' @param expr (`language`)\cr an R expression or call to test or strip of
28		#' `covr` trace counters.
29		#'
30		#' @return A logical value or transformed expression with calls to
31		#' `covr:::count` removed.
32		#'
33		#' @name h_covr_helpers
34		#' @keywords internal
35		#'
36		NULL
37
38		#' @describeIn h_covr_helpers
39		#' Determine whether `covr` is currently running
40		h_covr_active <- function() {
41	56429x	identical(Sys.getenv("R_COVR"), "true")
42		}
43
44		#' @describeIn h_covr_helpers
45		#' Remove `covr` traces from an expression
46		h_covr_detrace <- function(expr) {
47	55227x	if (!h_covr_active()) {
48	2x	return(expr)
49		}
50
51	55225x	if (is.function(expr)) {
52	9x	body(expr) <- h_covr_detrace(body(expr))
53	9x	return(expr)
54		}
55
56	55216x	detrace <- function(x) {
57		# returns "missing" expression to avoid errors with calls
58	55216x	if (identical(x, bquote())) {
59	223x	return(x)
60		}
61
62	54993x	x <- h_covr_detrace_call(x)
63	54993x	if (is.call(x)) {
64	27076x	x[-1] <- lapply(x[-1], h_covr_detrace)
65		}
66	54993x	x
67		}
68
69	55216x	detrace(expr)
70		}
71
72		#' @describeIn h_covr_helpers
73		#' Determine whether the current expression is a `covr`-modified expression
74		h_is_covr_trace <- function(expr) {
75		# Matches `if (TRUE) { covr:::count(<trace>); <expr> }` (see covr:::trace_calls).
76	54998x	is.call(expr) &&
77	54998x	expr[[1]] == "if" &&
78	54998x	expr[[2]] == quote(TRUE) &&
79	54998x	expr[[3]][[1]] == "{" &&
80	54998x	length(expr[[3]]) >= 3 &&
81	54998x	is.call(expr[[3]][[2]]) &&
82	54998x	expr[[3]][[2]][[1]] == call(":::", as.symbol("covr"), as.symbol("count"))
83		}
84
85		#' @describeIn h_covr_helpers
86		#' Extract the original expression from a `covr`-modified expression
87		h_covr_detrace_call <- function(expr) {
88	4021x	if (h_is_covr_trace(expr)) expr[[3]][[3]] else expr
89		}

1		#' Convenience function to make barplots of percentages
2		#'
3		#' @param x vector of samples
4		#' @param description xlab string
5		#' @param xaxisround rounding for xaxis labels (default: 0, i.e. integers will
6		#' be used)
7		#'
8		#' @return the ggplot2 object
9		#'
10		#' @keywords internal
11		#' @importFrom ggplot2 ggplot geom_histogram aes xlab ylab xlim
12		h_barplot_percentages <- function(x, description, xaxisround = 0) {
13	6x	assert_number(xaxisround, lower = 0)
14	4x	assert_character(description, len = 1, any.missing = FALSE)
15	2x	assert_numeric(x)
16
17	1x	tabx <- table(x) / length(x)
18	1x	dat <- data.frame(x = as.numeric(names(tabx)), perc = as.numeric(tabx) * 100)
19	1x	ggplot() +
20	1x	geom_bar(
21	1x	aes(x = x, y = perc),
22	1x	data = dat,
23	1x	stat = "identity",
24	1x	position = "identity",
25	1x	width = ifelse(nrow(dat) > 1, min(diff(dat$x)) / 2, 1)
26		) +
27	1x	xlab(description) +
28	1x	ylab("Percent") +
29	1x	scale_x_continuous(
30	1x	breaks = round(dat$x, xaxisround)
31		)
32		}
33
34
35		#' Helper function to calculate percentage of true stopping rules for
36		#' report label output
37		#' calculates true column means and converts output into percentages
38		#' before combining the output with the report label; output is passed
39		#' to [`show()`] and output with cat to console
40		#'
41		#' @param stop_report object from summary method
42		#' @return named list with label and percentage of rule activation
43
44		h_calc_report_label_percentage <- function(stop_report) {
45	2x	stop_pct <- colMeans(stop_report) * 100
46	2x	stop_pct_to_print <- stop_pct[!is.na(names(stop_pct))]
47	2x	return(stop_pct_to_print)
48		}
49
50
51		#' Helper function to calculate average across iterations for each additional
52		#' reporting parameter
53		#' extracts parameter names as specified by user and averaged the values
54		#' for each specified parameter to [`show()`] and output with cat to console
55		#'
56		#' @param stats_list object from simulation with nested parameter values
57		#' (sublist for each parameter)
58		#' @return list of parameter names and averaged values for console output
59
60		h_summarize_add_stats <- function(stats_list) {
61		# Extract the parameter names
62	2x	param_names <- names(stats_list[[1]])
63
64		# Calculate the average for each parameter
65	2x	averages <- lapply(param_names, function(param) {
66	4x	values <- sapply(stats_list, function(x) x[[param]])
67	4x	mean(values)
68		})
69
70	2x	return(list(param_names, averages))
71		}

1		#' Verbose Logging
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' A family of wrappers of selected [`futile.logger`] functions that control
6		#' the logging mechanism in `crmPack`. The `crmPack` uses [`futile.logger`]
7		#' package for the logging purposes. All the messages logged in `crmPack` are
8		#' logged into `crmPack` logger at the [`futile.logger::TRACE`] level. Hence,
9		#' enabling verbose logging means that the logging threshold will be set to
10		#' [`futile.logger::TRACE`] for the `crmPack` logger, and disabling verbose
11		#' logging means that it will be set to [`futile.logger::FATAL`].
12		#'
13		#' @describeIn enable_logging A simple wrapper of
14		#' [futile.logger::flog.threshold()] that enables `crmPack` verbose logging by
15		#' setting logging threshold to [`futile.logger::TRACE`] for `crmPack` logger.
16		#'
17		#' @export
18		#'
19		enable_logging <- function() {
20	3x	invisible(
21	3x	futile.logger::flog.threshold(futile.logger::TRACE, name = "crmPack")
22		)
23		}
24
25		#' @describeIn enable_logging A simple wrapper of
26		#' [futile.logger::flog.threshold()] that disables `crmPack` verbose logging
27		#' by setting logging threshold to [`futile.logger::FATAL`] for `crmPack`
28		#' logger.
29		#'
30		#' @export
31		#'
32		disable_logging <- function() {
33	6x	invisible(
34	6x	futile.logger::flog.threshold(futile.logger::FATAL, name = "crmPack")
35		)
36		}
37
38		#' @describeIn enable_logging A simple wrapper of
39		#' [futile.logger::flog.logger()] that checks whether current threshold level
40		#' for `crmPack` logger is verbose, which is [`futile.logger::TRACE`].
41		#' It returns `TRUE` if the current logging level is verbose, `FALSE`
42		#' otherwise.
43		#'
44		#' @export
45		#'
46		is_logging_enabled <- function() {
47	781x	logger <- futile.logger::flog.logger(name = "crmPack")
48	781x	unname(logger$threshold == futile.logger::TRACE)
49		}
50
51		#' @describeIn enable_logging A simple wrapper of
52		#' [futile.logger::flog.trace()] that prints a log message in the `crmPack`
53		#' logger.
54		#'
55		#' @inheritParams futile.logger::flog.trace
56		#'
57		#' @export
58		#'
59		log_trace <- function(msg, ..., capture = FALSE) {
60	1196x	assert_string(msg)
61	1196x	assert_flag(capture)
62
63	1196x	futile.logger::flog.trace(msg = msg, ..., name = "crmPack", capture = capture)
64		}

1		#' @include helpers.R
2		#' @include ModelParams-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# ModelParamsNormal ----
7
8		## class ----
9
10		#' `ModelParamsNormal`
11		#'
12		#' @description `r lifecycle::badge("experimental")`
13		#'
14		#' [`ModelParamsNormal`] is the class for a bivariate normal model parameters,
15		#' i.e. the mean vector, covariance matrix and precision matrix.
16		#' The precision matrix is an inverse of the covariance matrix in the
17		#' `JAGS` and it is computed internally by the object constructor function.
18		#'
19		#' @slot mean (`numeric`)\cr the mean vector.
20		#' @slot cov (`matrix`)\cr the covariance matrix.
21		#' @slot prec (`matrix`)\cr the precision matrix, which is an inverse matrix of the `cov`.
22		#'
23		#' @seealso [`ModelLogNormal`], [`LogisticNormalMixture`].
24		#'
25		#' @aliases ModelParamsNormal
26		#' @export
27		#'
28		.ModelParamsNormal <- setClass(
29		Class = "ModelParamsNormal",
30		slots = c(
31		mean = "numeric",
32		cov = "matrix",
33		prec = "matrix"
34		),
35		contains = "CrmPackClass",
36		validity = v_model_params_normal
37		)
38
39		## constructor ----
40
41		#' @rdname ModelParamsNormal-class
42		#'
43		#' @param mean (`numeric`)\cr the prior mean vector.
44		#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
45		#' `prec` is internally calculated as an inverse of `cov`.
46		#'
47		#' @export
48		#' @examples
49		#' ModelParamsNormal(mean = c(1, 6), cov = diag(2))
50		ModelParamsNormal <- function(mean, cov) {
51	764x	assert_matrix(
52	764x	cov,
53	764x	mode = "numeric",
54	764x	any.missing = FALSE,
55	764x	nrows = length(mean),
56	764x	ncols = length(mean)
57		)
58		# To ensure that `cov` is invertible:
59	764x	assert_true(h_is_positive_definite(cov, length(mean)))
60
61	764x	.ModelParamsNormal(
62	764x	mean = mean,
63	764x	cov = cov,
64	764x	prec = solve(cov)
65		)
66		}
67
68		## default constructor ----
69
70		#' @rdname ModelParamsNormal-class
71		#' @note Typically, end users will not use the `.ModelPAramsNormal()` function.
72		#' @export
73		.DefaultModelParamsNormal <- function() {
74	5x	ModelParamsNormal(
75	5x	mean = c(1, 0),
76	5x	cov = matrix(c(1, 0, 0, 1), nrow = 2)
77		)
78		}

1		#' @include McmcOptions-methods.R
2		NULL
3
4		# v_samples ----
5
6		#' Internal Helper Functions for Validation of [`Samples`] Objects
7		#'
8		#' @description These functions are only used internally to validate the format
9		#' of an input [`Samples`] or inherited classes and therefore not exported.
10		#'
11		#' @name v_samples_objects
12		#' @param object (`Samples`)\cr object to validate.
13		#' @return A `character` vector with the validation failure messages, or `TRUE`
14		#' in case validation passes.
15		NULL
16
17		#' @describeIn v_samples_objects validates that the [`Samples`] object contains
18		#' valid `data` slot.
19		v_samples <- function(object) {
20	7x	v <- Validate()
21	7x	v$check(
22	7x	all(sapply(object@data, NROW) == size(object@options)),
23	7x	"Every element in data must be of the same length (no. of rows) as the sample size was"
24		)
25	7x	v$check(
26	7x	all(sapply(object@data, test_numeric, finite = TRUE, any.missing = FALSE)),
27	7x	"Every element in data must be a finite object of type integer or double"
28		)
29	7x	v$result()
30		}

1		# nolint start
2
3		#' Object-oriented implementation of CRM designs
4		#'
5		#' @name crmPack
6		#' @title Object-oriented implementation of CRM designs
7		#' @import checkmate
8		#' @import ggplot2
9		#' @import methods
10		#' @import tibble
11		#' @importFrom grid grid.draw
12		#' @importFrom gridExtra arrangeGrob
13		#' @importFrom graphics plot hist legend lines matlines matplot
14		#' @importFrom stats binomial coef cov2cor gaussian glm lm median model.matrix
15		#' optim pgamma plogis pnorm qgamma qlogis qnorm quantile rbinom rgamma
16		#' approxfun rnorm runif uniroot var vcov step mad pbeta dbeta dgamma
17		#' setNames
18		#' @importFrom utils data head tail capture.output
19		#' @importFrom lifecycle badge
20		#' @importFrom rjags jags.model jags.samples
21		#' @importFrom futile.logger flog.threshold flog.logger flog.trace TRACE FATAL
22		#' @importFrom knitr knit_print
23		#' @importFrom kableExtra kbl add_header_above column_spec collapse_rows
24		#' kable_styling add_footnote kable
25		#'
26		#' @keywords package
27		#' @references Sabanes Bove D, Yeung WY, Palermo G, Jaki T (2019).
28		#' "Model-Based Dose Escalation Designs in R with crmPack."
29		#' Journal of Statistical Software, 89(10), 1-22.
30		#' doi:10.18637/jss.v089.i10 (URL: http://doi.org/10.18637/jss.v089.i10).
31		"_PACKAGE"
32
33		##' @keywords internal
34		.onAttach <- function(libname, pkgname) {
35	3x	packageStartupMessage(
36	3x	"Type crmPackHelp() to open help browser\n",
37	3x	"Type crmPackExample() to open example\n"
38		)
39		}
40
41		## need to declare global variable / function
42		## names in order to avoid R CMD check notes:
43		globalVariables(c(
44		"log.betaZ",
45		"precW",
46		"pow",
47		"nObs",
48		"betaZ",
49		"x",
50		"betaW",
51		"xLevel",
52		"precW",
53		"z",
54		"nGrid",
55		"doseGrid",
56		"betaWintercept",
57		"delta",
58		"deltaStart",
59		"delta2",
60		"Effsamples",
61		"logit<-",
62		"rho0",
63		"alpha0",
64		"delta0",
65		"alpha1",
66		"delta1",
67		"inverse",
68		"priorCov",
69		"theta",
70		"comp0",
71		"w",
72		"DLTs",
73		"y",
74		"group",
75		"annotate",
76		"probSamples",
77		"prec",
78		"nu",
79		"samples",
80		"Type",
81		"patient",
82		"toxicity",
83		"ID",
84		"biomarker",
85		"traj",
86		"Statistic",
87		"perc",
88		"..density..",
89		"middle",
90		"lower",
91		"upper",
92		"middleBiomarker",
93		"lowerBiomarker",
94		"upperBiomarker",
95		"nObsshare",
96		"xshare",
97		"yshare",
98		"thisProb.PL",
99		"thisMeanEff.PL",
100		"thisSize.PL",
101		"probit<-",
102		"refDose",
103		"Tmax",
104		"u",
105		"eps",
106		"h",
107		"lambda",
108		"cadj",
109		"A",
110		"lambda_p",
111		"cond",
112		"t0",
113		"tend",
114		"t0_case",
115		"tend_case",
116		"yhat",
117		"ref_dose",
118		"comp",
119		"X",
120		"skel_probs",
121		"is_combo",
122		"results",
123		"k",
124		"value",
125		"Parameter",
126		"intervals",
127		"Group",
128		"Tox",
129		"MaxOverdoseProb",
130		"DoseGrid",
131		"NGrid",
132		"NObs",
133		"XLevel"
134		))
135
136		# nolint end