crmPack coverage - 92.69%

Files
Source

#' @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
#' @slot any_backfilled (`flag`)\cr indicates if any backfill cohorts were used
#' @slot n_backfill (`ANY`)\cr number of patients in backfill cohorts (only if `any_backfilled=TRUE`)
#' @slot backfill_doses (`ANY`)\cr list with doses used in backfill cohorts (only if `any_backfilled=TRUE`)
#' @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",
      any_backfilled = "logical",
      n_backfill = "ANY",
      backfill_doses = "ANY"
    )
  )

## 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."
  )
}

# PseudoSimulationsSummary ----

## class ----

#' `PseudoSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures 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 target_end_of_trial (`numeric`)\cr the target probability of DLE wanted at the end of a trial
#' @slot target_dose_end_of_trial (`numeric`)\cr the dose level corresponds to the target probability
#'   of DLE wanted at the end of a trial, TDEOT
#' @slot target_dose_end_of_trial_at_dose_grid (`numeric`)\cr the dose level at dose grid corresponds to the
#'   target probability of DLE wanted at the end of a trial
#' @slot target_during_trial (`numeric`)\cr the target probability of DLE wanted during a trial
#' @slot target_dose_during_trial (`numeric`)\cr the dose level corresponds to the target probability of DLE
#'   wanted during the trial. TDDT
#' @slot target_dose_during_trial_at_dose_grid (`numeric`)\cr the dose level at dose grid corresponds to the
#'   target probability of DLE wanted during a trial
#' @slot tdeot_summary (`table`)\cr the six-number table summary, include the lowest, the 25th percentile
#'   (lower quartile), the 50th percentile (median), the mean, the 75th 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 tddt_summary (`table`)\cr the six-number table summary, include the lowest, the 25th percentile
#'   (lower quartile), the 50th percentile (median), the mean, the 75th 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 final_dose_rec_summary (`table`)\cr the six-number table summary, include the lowest, the 25th percentile
#'   (lower quartile), the 50th percentile (median), the mean, the 75th 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 ratio_tdeot_summary (`table`)\cr 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 final_ratio_summary (`table`)\cr 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 nsim (`integer`)\cr number of simulations
#' @slot prop_dle (`numeric`)\cr proportions of DLE in the trials
#' @slot mean_tox_risk (`numeric`)\cr mean toxicity risks for the patients
#' @slot dose_selected (`numeric`)\cr doses selected as MTD (target_dose_end_of_trial)
#' @slot tox_at_doses_selected (`numeric`)\cr true toxicity at doses selected
#' @slot prop_at_target_end_of_trial (`numeric`)\cr Proportion of trials selecting at the dose_grid closest below the
#'   MTD, the target_dose_end_of_trial
#' @slot prop_at_target_during_trial (`numeric`)\cr Proportion of trials selecting at the dose_grid closest below
#'   the target_dose_during_trial
#' @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 (`integer`)\cr number of patients overall
#' @slot n_above_target_end_of_trial (`integer`)\cr number of patients treated above target_dose_end_of_trial
#' @slot n_above_target_during_trial (`integer`)\cr number of patients treated above target_dose_during_trial
#' @slot dose_grid (`numeric`)\cr the dose grid that has been used
#' @slot fit_at_dose_most_selected (`numeric`)\cr fitted toxicity rate at dose most often selected
#' @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
#' @slot stop_report (`matrix`)\cr matrix of stopping rule outcomes
#'
#' @aliases PseudoSimulationsSummary
#' @export
.PseudoSimulationsSummary <-
  setClass(
    Class = "PseudoSimulationsSummary",
    slots = c(
      target_end_of_trial = "numeric",
      target_dose_end_of_trial = "numeric",
      target_dose_end_of_trial_at_dose_grid = "numeric",
      target_during_trial = "numeric",
      target_dose_during_trial = "numeric",
      target_dose_during_trial_at_dose_grid = "numeric",
      tdeot_summary = "table",
      tddt_summary = "table",
      final_dose_rec_summary = "table",
      ratio_tdeot_summary = "table",
      final_ratio_summary = "table",
      nsim = "integer",
      prop_dle = "numeric",
      mean_tox_risk = "numeric",
      dose_selected = "numeric",
      tox_at_doses_selected = "numeric",
      prop_at_target_end_of_trial = "numeric",
      prop_at_target_during_trial = "numeric",
      dose_most_selected = "numeric",
      obs_tox_rate_at_dose_most_selected = "numeric",
      n_obs = "integer",
      n_above_target_end_of_trial = "integer",
      n_above_target_during_trial = "integer",
      dose_grid = "numeric",
      fit_at_dose_most_selected = "numeric",
      mean_fit = "list",
      stop_report = "matrix"
    )
  )

## default constructor ----

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

# PseudoDualSimulationsSummary ----

## class ----

#' `PseudoDualSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the summary of the dual responses simulations using pseudo models.
#' It contains all slots from [`PseudoSimulationsSummary`] object. In addition to
#' the slots in the parent class [`PseudoSimulationsSummary`], it contains additional
#' 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 target_gstar (`numeric`)\cr the target dose level such that its gain value is at maximum
#' @slot target_gstar_at_dose_grid (`numeric`)\cr the dose level at dose Grid closest and below Gstar
#' @slot gstar_summary (`table`)\cr 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 ratio_gstar_summary (`table`)\cr 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 eff_fit_at_dose_most_selected (`numeric`)\cr fitted expected mean efficacy value at dose most often
#'   selected
#' @slot mean_eff_fit (`list`)\cr list with mean, lower (2.5%) and upper (97.5%) quantiles of the fitted expected
#'   efficacy value at each dose level.
#'
#' @aliases PseudoDualSimulationsSummary
#' @export
.PseudoDualSimulationsSummary <-
  setClass(
    Class = "PseudoDualSimulationsSummary",
    contains = "PseudoSimulationsSummary",
    slots = c(
      target_gstar = "numeric",
      target_gstar_at_dose_grid = "numeric",
      gstar_summary = "table",
      ratio_gstar_summary = "table",
      eff_fit_at_dose_most_selected = "numeric",
      mean_eff_fit = "list"
    )
  )

## default constructor ----

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

# DASimulations ----

## class ----

#' `DASimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the trial simulations from DA based designs.
#' In comparison to the parent class [`Simulations`],
#' it contains additional slots to capture the time to DLT fits, additional
#' parameters and the trial duration.
#'
#' @slot trial_duration (`numeric`)\cr the vector of trial duration values for all simulations.
#'
#' @aliases DASimulations
#' @export
.DASimulations <-
  setClass(
    Class = "DASimulations",
    slots = c(trial_duration = "numeric"),
    prototype = prototype(trial_duration = rep(0, 2)),
    contains = "Simulations",
    validity = v_da_simulations
  )

## constructor ----

#' @rdname DASimulations-class
#'
#' @param trial_duration (`numeric`)\cr see [`DASimulations`]
#' @param \dots additional parameters from [`Simulations`]
#'
#' @export
DASimulations <- function(trial_duration, ...) {
  start <- Simulations(...)
  .DASimulations(start, trial_duration = trial_duration)
}


## default constructor ----

#' @rdname DASimulations-class
#' @note Typically, end users will not use the `.DefaultDASimulations()` function.
#' @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
  )
}

# 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)
  }
)

#' @include Data-methods.R
#' @include Design-class.R
#' @include McmcOptions-class.R
#' @include Rules-methods.R
#' @include Backfill-methods.R
#' @include Simulations-class.R
#' @include helpers.R
#' @include mcmc.R
NULL

# simulate ----

## Design ----

#' Simulate outcomes from a CRM design
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param object the [`Design`] object we want to simulate data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param truth (`function`)\cr a function which takes as input a dose (vector) and returns the
#'   true probability (vector) for toxicity. Additional arguments can be supplied
#'   in `args`.
#' @param truthResponse (`function`)\cr a function which takes as input a dose (vector) and returns the
#'   probability (vector) for a positive efficacy response.
#' @param args (`data.frame`)\cr data frame with arguments for the `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 `nsim`
#'   simulations. In order to produce outcomes from the posterior predictive
#'   distribution, e.g, pass an `object` that contains the data observed so
#'   far, `truth` contains the `prob` function from the model in
#'   `object`, and `args` contains posterior samples from the model.
#' @param firstSeparate (`flag`)\cr 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 ([McmcOptions])\cr object of class [`McmcOptions`],
#'   giving the MCMC options for each evaluation in the trial. By default,
#'   the standard options are used
#' @param parallel (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param ... not used
#' @param derive (`list`)\cr 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 [`Simulations`]
#'
#' @example examples/design-method-simulate-Design.R
#' @export
#' @importFrom parallel detectCores
setMethod(
  f = "simulate",
  signature = signature(
    object = "Design",
    nsim = "ANY",
    seed = "ANY"
  ),
  definition = function(
    object,
    nsim = 1L,
    seed = NULL,
    truth,
    truthResponse = plogis,
    args = NULL,
    firstSeparate = FALSE,
    mcmcOptions = McmcOptions(),
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5),
    derive = list(),
    ...
  ) {
    nsim <- as.integer(nsim)
    assert_function(truth)
    assert_function(truthResponse)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    # Does this design use backfill cohorts? If no we can skip the corresponding
    # computations later.
    uses_backfill <- !is(object@backfill@opening, "OpeningNone")

    args <- as.data.frame(args)
    n_args <- max(nrow(args), 1L)
    rng_state <- set_seed(seed)
    sim_seeds <- sample.int(n = 2147483647, size = as.integer(nsim))

    run_sim <- function(iter_sim) {
      set.seed(sim_seeds[iter_sim])

      current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]
      data <- object@data
      prob_placebo <- NULL
      cohort_size_placebo <- NULL
      prob_response_placebo <- NULL

      if (data@placebo) {
        placebo_dose <- object@data@doseGrid[1]
        prob_placebo <- h_this_truth(placebo_dose, current_args, truth)
        prob_response_placebo <- truthResponse(placebo_dose)
      }

      should_stop <- FALSE
      dose <- object@startingDose
      backfill_cohorts <- list() # Queue of backfill cohorts.
      backfill_patients <- 0L # Total number of backfill patients enrolled.

      while (!should_stop) {
        prob <- h_this_truth(dose, current_args, truth)
        prob_response <- truthResponse(dose)

        cohort_size <- size(object@cohort_size, dose = dose, data = data)

        if (data@placebo) {
          cohort_size_placebo <- size(
            object@pl_cohort_size,
            dose = dose,
            data = data
          )
        } else {
          cohort_size_placebo <- NULL
        }

        data <- h_determine_dlts(
          data = data,
          dose = dose,
          prob = prob,
          prob_placebo = prob_placebo,
          prob_response = prob_response,
          prob_response_placebo = prob_response_placebo,
          cohort_size = cohort_size,
          cohort_size_placebo = cohort_size_placebo,
          dose_grid = data@doseGrid,
          first_separate = firstSeparate
        )

        # Backfill logic.
        if (uses_backfill) {
          backfill_cohorts <- h_update_backfill_queue(
            backfill_cohorts = backfill_cohorts,
            data = data,
            dose = dose,
            backfill = object@backfill
          )

          enrollment_result <- h_enroll_backfill_patients(
            backfill_cohorts = backfill_cohorts,
            data = data,
            backfill = object@backfill,
            cohort_size = cohort_size,
            backfill_patients = backfill_patients,
            current_args = current_args,
            truth = truth,
            truthResponse = truthResponse
          )

          data <- enrollment_result$data
          backfill_cohorts <- enrollment_result$backfill_cohorts
          backfill_patients <- enrollment_result$backfill_patients
        }

        dose_limit <- maxDose(object@increments, data = data)
        samples <- mcmc(
          data = data,
          model = object@model,
          options = mcmcOptions
        )

        dose <- nextBest(
          object@nextBest,
          doselimit = dose_limit,
          samples = samples,
          model = object@model,
          data = data
        )$value

        should_stop <- stopTrial(
          object@stopping,
          dose = dose,
          samples = samples,
          model = object@model,
          data = data
        )
        stopit_results <- h_unpack_stopit(should_stop)
      }

      fit_model <- fit(object = samples, model = object@model, data = data)
      target_dose_samples <- dose(
        mean(object@nextBest@target),
        model = object@model,
        samples = samples
      )
      additional_stats <- lapply(derive, function(f) f(target_dose_samples))

      list(
        data = data,
        dose = dose,
        fit = subset(fit_model, select = c(middle, lower, upper)),
        stop = attr(should_stop, "message"),
        report_results = stopit_results,
        additional_stats = additional_stats
      )
    }

    result_list <- get_result_list(
      fun = run_sim,
      nsim = nsim,
      vars = c(
        "sim_seeds",
        "args",
        "n_args",
        "firstSeparate",
        "truth",
        "truthResponse",
        "object",
        "mcmcOptions"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    simulations_output <- h_simulations_output_format(result_list)

    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 = rng_state
    )
  }
)

## RuleDesign ----

#' Simulate outcomes from a rule-based design
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param object the [`RuleDesign`] object we want to simulate data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param truth (`function`)\cr a function which takes as input a dose (vector) and returns the
#'   true probability (vector) for toxicity. Additional arguments can be supplied
#'   in `args`.
#' @param args (`data.frame`)\cr data frame with arguments for the `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 `nsim`
#'   simulations.
#' @param parallel (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param ... not used
#'
#' @return an object of class [`GeneralSimulations`]
#'
#' @example examples/design-method-simulate-RuleDesign.R
#' @export
setMethod(
  f = "simulate",
  signature = signature(
    object = "RuleDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  definition = function(
    object,
    nsim = 1L,
    seed = NULL,
    truth,
    args = NULL,
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5L),
    ...
  ) {
    nsim <- as.integer(nsim)
    assert_function(truth)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)
    assert_class(object, "RuleDesign")

    args <- as.data.frame(args)
    n_args <- max(nrow(args), 1L)
    rng_state <- set_seed(seed)
    sim_seeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

    run_sim <- function(iter_sim) {
      set.seed(sim_seeds[iter_sim])

      current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

      truth_with_args <- function(dose) {
        do.call(truth, c(dose, current_args))
      }

      data <- object@data
      should_stop <- FALSE
      dose <- object@startingDose

      while (!should_stop) {
        prob <- truth_with_args(dose)
        cohort_size <- size(object@cohort_size, dose = dose, data = data)

        dlts <- rbinom(n = cohort_size, size = 1L, prob = prob)
        data <- update(object = data, x = dose, y = dlts)

        outcome <- nextBest(object@nextBest, data = data)
        dose <- outcome$value
        should_stop <- outcome$stopHere
      }

      list(data = data, dose = dose)
    }

    result_list <- get_result_list(
      fun = run_sim,
      nsim = nsim,
      vars = c(
        "sim_seeds",
        "args",
        "n_args",
        "truth",
        "object"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    data_list <- lapply(result_list, "[[", "data")
    recommended_doses <- as.numeric(sapply(result_list, "[[", "dose"))

    GeneralSimulations(
      data = data_list,
      doses = recommended_doses,
      seed = rng_state
    )
  }
)

## DualDesign ----

#' Simulate outcomes from a dual-endpoint design
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param object the [`DualDesign`] object we want to simulate data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param trueTox (`function`)\cr a function which takes as input a dose (vector) and returns the
#'   true probability (vector) for toxicity. Additional arguments can be supplied
#'   in `args`.
#' @param trueBiomarker (`function`)\cr a function which takes as input a dose (vector) and
#'   returns the true biomarker level (vector). Additional arguments can be
#'   supplied in `args`.
#' @param args (`data.frame`)\cr data frame with arguments for the `trueTox` and
#'   `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 `nsim` simulations.
#' @param sigma2W (`number`)\cr variance for the biomarker measurements
#' @param rho (`number`)\cr correlation between toxicity and biomarker measurements (default: 0)
#' @param firstSeparate (`flag`)\cr 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 ([McmcOptions])\cr object of class [`McmcOptions`],
#'   giving the MCMC options for each evaluation in the trial. By default,
#'   the standard options are used
#' @param parallel (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param ... not used
#' @param derive (`list`)\cr 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 [`DualSimulations`]
#'
#' @note Backfill cohorts are not yet implemented and therefore will lead to an error if used
#'   in the `DualDesign` object.
#'
#' @example examples/design-method-simulate-DualDesign.R
#' @importFrom mvtnorm rmvnorm
#' @export
setMethod(
  f = "simulate",
  signature = signature(object = "DualDesign"),
  definition = 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(),
    ...
  ) {
    nsim <- as.integer(nsim)
    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)
    assert_class(object, "DualDesign")
    assert_list(derive)
    assert_class(object@backfill@opening, "OpeningNone")

    args <- as.data.frame(args)
    n_args <- max(nrow(args), 1L)

    tox_arg_names <- names(formals(trueTox))[-1]
    biomarker_arg_names <- names(formals(trueBiomarker))[-1]

    covariance_matrix <- matrix(
      c(
        sigma2W,
        sqrt(sigma2W) * rho,
        sqrt(sigma2W) * rho,
        1
      ),
      nrow = 2,
      byrow = TRUE
    )

    rng_state <- set_seed(seed)
    sim_seeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

    run_sim <- function(iter_sim) {
      set.seed(sim_seeds[iter_sim])

      current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

      tox_with_args <- function(dose) {
        do.call(
          trueTox,
          c(dose, as.list(current_args)[tox_arg_names])
        )
      }

      biomarker_with_args <- function(dose) {
        do.call(
          trueBiomarker,
          c(dose, as.list(current_args)[biomarker_arg_names])
        )
      }

      data <- object@data
      should_stop <- FALSE
      dose <- object@startingDose

      prob_placebo <- NULL
      mean_z_placebo <- NULL
      mean_biomarker_placebo <- NULL

      if (data@placebo) {
        prob_placebo <- tox_with_args(object@data@doseGrid[1])
        mean_z_placebo <- qlogis(prob_placebo)
        mean_biomarker_placebo <- biomarker_with_args(object@data@doseGrid[1])
      }

      while (!should_stop) {
        prob <- tox_with_args(dose)
        mean_z <- qlogis(prob)
        mean_biomarker <- biomarker_with_args(dose)
        cohort_size <- size(object@cohort_size, dose = dose, data = data)

        cohort_size_placebo <- NULL
        if (data@placebo) {
          cohort_size_placebo <- size(
            object@pl_cohort_size,
            dose = dose,
            data = data
          )
        }

        response_data <- if (firstSeparate && (cohort_size > 1L)) {
          first_patient <- mvtnorm::rmvnorm(
            n = 1,
            mean = c(mean_biomarker, mean_z),
            sigma = covariance_matrix
          )

          first_patient_placebo <- NULL
          if (data@placebo && (cohort_size_placebo > 0L)) {
            first_patient_placebo <- mvtnorm::rmvnorm(
              n = 1,
              mean = c(mean_biomarker_placebo, mean_z_placebo),
              sigma = covariance_matrix
            )
          }

          if (first_patient[, 2] < 0) {
            remaining_patients <- mvtnorm::rmvnorm(
              n = cohort_size - 1,
              mean = c(mean_biomarker, mean_z),
              sigma = covariance_matrix
            )
            first_patient <- rbind(first_patient, remaining_patients)

            if (data@placebo && (cohort_size_placebo > 0L)) {
              remaining_patients_placebo <- mvtnorm::rmvnorm(
                n = cohort_size_placebo,
                mean = c(mean_biomarker_placebo, mean_z_placebo),
                sigma = covariance_matrix
              )
              first_patient_placebo <- rbind(
                first_patient_placebo,
                remaining_patients_placebo
              )
            }
          }

          if (data@placebo && (cohort_size_placebo > 0L)) {
            list(active = first_patient, placebo = first_patient_placebo)
          } else {
            list(active = first_patient)
          }
        } else {
          active_responses <- mvtnorm::rmvnorm(
            n = cohort_size,
            mean = c(mean_biomarker, mean_z),
            sigma = covariance_matrix
          )

          placebo_responses <- NULL
          if (data@placebo && (cohort_size_placebo > 0L)) {
            placebo_responses <- mvtnorm::rmvnorm(
              n = cohort_size_placebo,
              mean = c(mean_biomarker_placebo, mean_z_placebo),
              sigma = covariance_matrix
            )
          }

          if (data@placebo && (cohort_size_placebo > 0L)) {
            list(active = active_responses, placebo = placebo_responses)
          } else {
            list(active = active_responses)
          }
        }

        biomarkers <- response_data$active[, 1]
        dlts <- as.integer(response_data$active[, 2] > 0)

        if (data@placebo && (cohort_size_placebo > 0L)) {
          biomarkers_placebo <- response_data$placebo[, 1]
          dlts_placebo <- as.integer(response_data$placebo[, 2] > 0)

          data <- update(
            object = data,
            x = object@data@doseGrid[1],
            y = dlts_placebo,
            w = biomarkers_placebo,
            check = FALSE
          )

          data <- update(
            object = data,
            x = dose,
            y = dlts,
            w = biomarkers,
            new_cohort = FALSE
          )
        } else {
          data <- update(
            object = data,
            x = dose,
            y = dlts,
            w = biomarkers
          )
        }

        dose_limit <- maxDose(object@increments, data = data)
        samples <- mcmc(
          data = data,
          model = object@model,
          options = mcmcOptions
        )

        dose <- nextBest(
          object@nextBest,
          doselimit = dose_limit,
          samples = samples,
          model = object@model,
          data = data
        )$value

        should_stop <- stopTrial(
          object@stopping,
          dose = dose,
          samples = samples,
          model = object@model,
          data = data
        )
        stopit_results <- h_unpack_stopit(should_stop)
      }

      fit_model <- fit(object = samples, model = object@model, data = data)

      target_dose_samples <- dose(
        mean(object@nextBest@target),
        model = object@model,
        samples = samples
      )

      additional_stats <- lapply(derive, function(f) f(target_dose_samples))

      list(
        data = data,
        dose = dose,
        fitTox = subset(fit_model, select = c(middle, lower, upper)),
        fit_biomarker = subset(
          fit_model,
          select = c(middleBiomarker, lowerBiomarker, upperBiomarker)
        ),
        rho_est = median(samples@data$rho),
        sigma2w_est = median(1 / samples@data$precW),
        stop = attr(should_stop, "message"),
        additional_stats = additional_stats,
        report_results = stopit_results
      )
    }

    result_list <- get_result_list(
      fun = run_sim,
      nsim = nsim,
      vars = c(
        "sim_seeds",
        "args",
        "n_args",
        "firstSeparate",
        "trueTox",
        "trueBiomarker",
        "covariance_matrix",
        "object",
        "mcmcOptions"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    data_list <- lapply(result_list, "[[", "data")
    recommended_doses <- as.numeric(sapply(result_list, "[[", "dose"))
    rho_estimates <- as.numeric(sapply(result_list, "[[", "rho_est"))
    sigma2w_estimates <- as.numeric(sapply(result_list, "[[", "sigma2w_est"))
    fit_tox_list <- lapply(result_list, "[[", "fitTox")
    fit_biomarker_list <- lapply(result_list, "[[", "fit_biomarker")
    stop_reasons <- lapply(result_list, "[[", "stop")
    stop_results <- lapply(result_list, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))
    additional_stats <- lapply(result_list, "[[", "additional_stats")

    DualSimulations(
      data = data_list,
      doses = recommended_doses,
      rho_est = rho_estimates,
      sigma2w_est = sigma2w_estimates,
      fit = fit_tox_list,
      fit_biomarker = fit_biomarker_list,
      stop_report = stop_report,
      stop_reasons = stop_reasons,
      additional_stats = additional_stats,
      seed = rng_state
    )
  }
)

## TDsamplesDesign ----

#' Simulate dose escalation procedure using DLE responses only with DLE samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a method to simulate dose escalation procedure only using the DLE responses.
#' This is a method based on the [`TDsamplesDesign`] where model used are of
#' [`ModelTox`] class object DLE samples are also used.
#'
#' @param object the [`TDsamplesDesign`] object we want to simulate the data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param truth (`function`)\cr 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 `args`.
#' @param args (`data.frame`)\cr data frame with arguments for the `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 `nsim`
#'   simulations. In order to produce outcomes from the posterior predictive
#'   distribution, e.g, pass an `object` that contains the data observed so
#'   far, `truth` contains the `prob` function from the model in
#'   `object`, and `args` contains posterior samples from the model.
#' @param firstSeparate (`flag`)\cr 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 ([McmcOptions])\cr object of class [`McmcOptions`],
#'   giving the MCMC options for each evaluation in the trial. By default,
#'   the standard options are used
#' @param parallel (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param ... not used
#'
#' @return an object of class [`PseudoSimulations`]
#'
#' @example examples/design-method-simulateTDsamplesDesign.R
#' @export
setMethod(
  f = "simulate",
  signature = signature(
    object = "TDsamplesDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  definition = function(
    object,
    nsim = 1L,
    seed = NULL,
    truth,
    args = NULL,
    firstSeparate = FALSE,
    mcmcOptions = McmcOptions(),
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5L),
    ...
  ) {
    nsim <- as.integer(nsim)
    assert_function(truth)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)
    assert_class(object, "TDsamplesDesign")

    args <- as.data.frame(args)
    n_args <- max(nrow(args), 1L)
    rng_state <- set_seed(seed)

    # Keep original seed generation for snapshot test compatibility
    sim_seeds <- sample(x = seq_len(1e5), size = nsim)

    run_sim <- function(iter_sim) {
      set.seed(sim_seeds[iter_sim])

      current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

      truth_with_args <- function(dose) {
        do.call(truth, c(dose, current_args))
      }

      data <- object@data
      prob_placebo <- NULL

      if (data@placebo) {
        prob_placebo <- truth_with_args(object@data@doseGrid[1])
      }

      should_stop <- FALSE
      dose <- object@startingDose

      while (!should_stop) {
        prob <- truth_with_args(dose)
        cohort_size <- size(object@cohort_size, dose = dose, data = data)

        cohort_size_placebo <- NULL
        if (data@placebo) {
          cohort_size_placebo <- size(
            object@pl_cohort_size,
            dose = dose,
            data = data
          )
        }

        dlts <- if (firstSeparate && (cohort_size > 1L)) {
          first_dlt <- rbinom(n = 1L, size = 1L, prob = prob)

          dlts_placebo_first <- NULL
          if (data@placebo && (cohort_size_placebo > 0L)) {
            dlts_placebo_first <- rbinom(n = 1L, size = 1L, prob = prob_placebo)
          }

          if (first_dlt == 0) {
            remaining_dlts <- rbinom(
              n = cohort_size - 1L,
              size = 1L,
              prob = prob
            )
            c(first_dlt, remaining_dlts)
          } else {
            first_dlt
          }
        } else {
          rbinom(n = cohort_size, size = 1L, prob = prob)
        }

        dlts_placebo <- NULL
        if (data@placebo && (cohort_size_placebo > 0L)) {
          if (firstSeparate && (cohort_size > 1L) && length(dlts) == 1) {
            dlts_placebo <- dlts_placebo_first
          } else {
            dlts_placebo <- if (firstSeparate && (cohort_size > 1L)) {
              c(
                dlts_placebo_first,
                rbinom(
                  n = cohort_size_placebo,
                  size = 1L,
                  prob = prob_placebo
                )
              )
            } else {
              rbinom(n = cohort_size_placebo, size = 1L, prob = prob_placebo)
            }
          }
        }

        if (data@placebo && (cohort_size_placebo > 0L)) {
          data <- update(object = data, x = dose, y = dlts)
          data <- update(
            object = data,
            x = object@data@doseGrid[1],
            y = dlts_placebo,
            new_cohort = FALSE
          )
        } else {
          data <- update(object = data, x = dose, y = dlts)
        }

        model <- update(object@model, data = data)
        dose_limit <- maxDose(object@increments, data = data)
        samples <- mcmc(data = data, model = model, options = mcmcOptions)

        next_best_result <- nextBest(
          object@nextBest,
          doselimit = dose_limit,
          samples = samples,
          model = model,
          data = data,
          in_sim = TRUE
        )

        dose <- next_best_result$next_dose_drt
        td_target_during_trial <- next_best_result$dose_target_drt
        td_target_end_of_trial <- next_best_result$dose_target_eot
        td_target_end_of_trial_at_dose_grid <- next_best_result$next_dose_eot
        ci_tdeot <- list(
          lower = next_best_result$ci_dose_target_eot[1],
          upper = next_best_result$ci_dose_target_eot[2]
        )
        ratio_tdeot <- next_best_result$ci_ratio_dose_target_eot

        should_stop <- stopTrial(
          object@stopping,
          dose = dose,
          samples = samples,
          model = model,
          data = data
        )
        stopit_results <- h_unpack_stopit(should_stop)
      }

      fit_model <- fit(object = samples, model = model, data = data)

      list(
        data = data,
        dose = dose,
        TDtargetDuringTrial = td_target_during_trial,
        TDtargetEndOfTrial = td_target_end_of_trial,
        TDtargetEndOfTrialatdoseGrid = td_target_end_of_trial_at_dose_grid,
        TDtargetDuringTrialatdoseGrid = dose,
        CITDEOT = ci_tdeot,
        ratioTDEOT = ratio_tdeot,
        fit = subset(fit_model, select = c(middle, lower, upper)),
        stop = attr(should_stop, "message"),
        report_results = stopit_results
      )
    }

    result_list <- get_result_list(
      fun = run_sim,
      nsim = nsim,
      vars = c(
        "sim_seeds",
        "args",
        "n_args",
        "firstSeparate",
        "truth",
        "object",
        "mcmcOptions"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    data_list <- lapply(result_list, "[[", "data")

    td_target_during_trial_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetDuringTrial"
    ))

    td_target_end_of_trial_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrial"
    ))

    td_target_during_trial_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetDuringTrialatdoseGrid"
    ))

    td_target_end_of_trial_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrialatdoseGrid"
    ))

    recommended_doses <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrialatdoseGrid"
    ))

    ci_list <- lapply(result_list, "[[", "CITDEOT")
    ratio_list <- as.numeric(sapply(result_list, "[[", "ratioTDEOT"))
    ci_tdeot_list <- lapply(result_list, "[[", "CITDEOT")
    ratio_tdeot_list <- as.numeric(sapply(result_list, "[[", "ratioTDEOT"))
    fit_list <- lapply(result_list, "[[", "fit")
    stop_reasons <- lapply(result_list, "[[", "stop")

    stop_results <- lapply(result_list, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))

    PseudoSimulations(
      data = data_list,
      doses = recommended_doses,
      fit = fit_list,
      final_td_target_during_trial_estimates = td_target_during_trial_list,
      final_td_target_end_of_trial_estimates = td_target_end_of_trial_list,
      final_td_target_during_trial_at_dose_grid = td_target_during_trial_dose_grid_list,
      final_td_target_end_of_trial_at_dose_grid = td_target_end_of_trial_dose_grid_list,
      final_cis = ci_list,
      final_ratios = ratio_list,
      final_tdeot_cis = ci_tdeot_list,
      final_tdeot_ratios = ratio_tdeot_list,
      stop_reasons = stop_reasons,
      stop_report = stop_report,
      seed = rng_state
    )
  }
)

## TDDesign ----

#' Simulate dose escalation procedure using DLE responses only without samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a method to simulate dose escalation procedure only using the DLE responses.
#' This is a method based on the [`TDDesign`] where model used are of
#' [`ModelTox`] class object and no samples are involved.
#'
#' @param object the [`TDDesign`] object we want to simulate the data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param truth (`function`)\cr 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 `args`.
#' @param args (`data.frame`)\cr data frame with arguments for the `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 `nsim`
#'   simulations. In order to produce outcomes from the posterior predictive
#'   distribution, e.g, pass an `object` that contains the data observed so
#'   far, `truth` contains the `prob` function from the model in
#'   `object`, and `args` contains posterior samples from the model.
#' @param firstSeparate (`flag`)\cr 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 (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param ... not used
#'
#' @return an object of class [`PseudoSimulations`]
#'
#' @example examples/design-method-simulateTDDesign.R
#' @export
setMethod(
  f = "simulate",
  signature = signature(
    object = "TDDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  definition = function(
    object,
    nsim = 1L,
    seed = NULL,
    truth,
    args = NULL,
    firstSeparate = FALSE,
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5L),
    ...
  ) {
    nsim <- as.integer(nsim)
    assert_function(truth)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)
    assert_class(object, "TDDesign")

    args <- as.data.frame(args)
    n_args <- max(nrow(args), 1L)
    rng_state <- set_seed(seed)

    # Keep original seed generation for snapshot test compatibility
    sim_seeds <- sample(x = seq_len(1e5), size = nsim)

    run_sim <- function(iter_sim) {
      set.seed(sim_seeds[iter_sim])

      current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

      truth_with_args <- function(dose) {
        do.call(truth, c(dose, current_args))
      }

      data <- object@data
      prob_placebo <- NULL

      if (data@placebo) {
        prob_placebo <- truth_with_args(object@data@doseGrid[1])
      }

      should_stop <- FALSE
      dose <- object@startingDose

      while (!should_stop) {
        prob <- truth_with_args(dose)
        cohort_size <- size(object@cohort_size, dose = dose, data = data)

        cohort_size_placebo <- NULL
        if (data@placebo) {
          cohort_size_placebo <- size(
            object@pl_cohort_size,
            dose = dose,
            data = data
          )
        }

        dlts <- if (firstSeparate && (cohort_size > 1L)) {
          first_dlt <- rbinom(n = 1L, size = 1L, prob = prob)

          dlts_placebo_first <- NULL
          if (data@placebo && (cohort_size_placebo > 0L)) {
            dlts_placebo_first <- rbinom(n = 1L, size = 1L, prob = prob_placebo)
          }

          if (first_dlt == 0) {
            remaining_dlts <- rbinom(
              n = cohort_size - 1L,
              size = 1L,
              prob = prob
            )
            c(first_dlt, remaining_dlts)
          } else {
            first_dlt
          }
        } else {
          rbinom(n = cohort_size, size = 1L, prob = prob)
        }

        dlts_placebo <- NULL
        if (data@placebo && (cohort_size_placebo > 0L)) {
          if (firstSeparate && (cohort_size > 1L) && length(dlts) == 1) {
            dlts_placebo <- dlts_placebo_first
          } else {
            dlts_placebo <- rbinom(
              n = cohort_size_placebo,
              size = 1L,
              prob = prob_placebo
            )
          }
        }

        if (data@placebo && (cohort_size_placebo > 0L)) {
          data <- update(
            object = data,
            x = object@data@doseGrid[1],
            y = dlts_placebo
          )
          data <- update(
            object = data,
            x = dose,
            y = dlts,
            new_cohort = FALSE
          )
        } else {
          data <- update(object = data, x = dose, y = dlts)
        }

        model <- update(object@model, data = data)
        dose_limit <- maxDose(object@increments, data = data)

        next_best_result <- nextBest(
          object@nextBest,
          doselimit = dose_limit,
          model = model,
          data = data,
          in_sim = TRUE
        )

        dose <- next_best_result$next_dose_drt
        td_target_during_trial <- next_best_result$dose_target_drt
        td_target_end_of_trial <- next_best_result$dose_target_eot
        td_target_end_of_trial_at_dose_grid <- next_best_result$next_dose_eot
        ci_tdeot <- list(
          lower = next_best_result$ci_dose_target_eot[1],
          upper = next_best_result$ci_dose_target_eot[2]
        )
        ratio_tdeot <- next_best_result$ci_ratio_dose_target_eot

        should_stop <- stopTrial(
          object@stopping,
          dose = dose,
          model = model,
          data = data
        )
        stopit_results <- h_unpack_stopit(should_stop)
      }

      prob_fun <- probFunction(
        model,
        phi1 = model@phi1,
        phi2 = model@phi2
      )
      fit_model <- list(
        phi1 = model@phi1,
        phi2 = model@phi2,
        probDLE = prob_fun(object@data@doseGrid)
      )

      list(
        data = data,
        dose = dose,
        TDtargetDuringTrial = td_target_during_trial,
        TDtargetEndOfTrial = td_target_end_of_trial,
        TDtargetEndOfTrialatdoseGrid = td_target_end_of_trial_at_dose_grid,
        TDtargetDuringTrialatdoseGrid = dose,
        CITDEOT = ci_tdeot,
        ratioTDEOT = ratio_tdeot,
        fit = fit_model,
        stop = attr(should_stop, "message"),
        report_results = stopit_results
      )
    }

    result_list <- get_result_list(
      fun = run_sim,
      nsim = nsim,
      vars = c(
        "sim_seeds",
        "args",
        "n_args",
        "firstSeparate",
        "truth",
        "object"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    data_list <- lapply(result_list, "[[", "data")

    td_target_during_trial_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetDuringTrial"
    ))

    td_target_end_of_trial_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrial"
    ))

    td_target_during_trial_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetDuringTrialatdoseGrid"
    ))

    td_target_end_of_trial_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrialatdoseGrid"
    ))

    recommended_doses <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrialatdoseGrid"
    ))

    ci_list <- lapply(result_list, "[[", "CITDEOT")
    ratio_list <- as.numeric(sapply(result_list, "[[", "ratioTDEOT"))
    ci_tdeot_list <- lapply(result_list, "[[", "CITDEOT")
    ratio_tdeot_list <- as.numeric(sapply(result_list, "[[", "ratioTDEOT"))
    fit_list <- lapply(result_list, "[[", "fit")
    stop_reasons <- lapply(result_list, "[[", "stop")

    stop_results <- lapply(result_list, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))

    PseudoSimulations(
      data = data_list,
      doses = recommended_doses,
      fit = fit_list,
      final_td_target_during_trial_estimates = td_target_during_trial_list,
      final_td_target_end_of_trial_estimates = td_target_end_of_trial_list,
      final_td_target_during_trial_at_dose_grid = td_target_during_trial_dose_grid_list,
      final_td_target_end_of_trial_at_dose_grid = td_target_end_of_trial_dose_grid_list,
      final_cis = ci_list,
      final_ratios = ratio_list,
      final_tdeot_cis = ci_tdeot_list,
      final_tdeot_ratios = ratio_tdeot_list,
      stop_reasons = stop_reasons,
      stop_report = stop_report,
      seed = rng_state
    )
  }
)

## DualResponsesDesign ----

#' Simulate dose escalation procedure using both DLE and efficacy responses without samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a method to simulate dose escalation procedure using both DLE and efficacy responses.
#' This is a method based on the [`DualResponsesDesign`] where DLE model used are of
#' [`ModelTox`] class object and efficacy model used are of [`ModelEff`]
#' class object. In addition, no DLE and efficacy samples are involved or generated in the simulation
#' process.
#'
#' @param object the [`DualResponsesDesign`] object we want to simulate the data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param trueDLE (`function`)\cr 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 `args`.
#' @param trueEff (`function`)\cr a function which takes as input a dose (vector) and returns the expected efficacy
#'   responses (vector). Additional arguments can be supplied in `args`.
#' @param trueNu (`number`)\cr the precision, the inverse of the variance of the efficacy responses
#' @param args (`data.frame`)\cr data frame with arguments for the `trueDLE` and
#'   `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 `nsim` simulations.
#' @param firstSeparate (`flag`)\cr 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 (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param ... not used
#'
#' @return an object of class [`PseudoDualSimulations`]
#'
#' @example examples/design-method-simulateDualResponsesDesign.R
#' @export
setMethod(
  f = "simulate",
  signature = signature(
    object = "DualResponsesDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  definition = function(
    object,
    nsim = 1L,
    seed = NULL,
    trueDLE,
    trueEff,
    trueNu,
    args = NULL,
    firstSeparate = FALSE,
    parallel = FALSE,
    nCores = min(parallel::detectCores(), 5L),
    ...
  ) {
    nsim <- as.integer(nsim)
    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)
    assert_class(object, "DualResponsesDesign")

    args <- as.data.frame(args)
    n_args <- max(nrow(args), 1L)

    dle_arg_names <- names(formals(trueDLE))[-1]
    eff_arg_names <- names(formals(trueEff))[-1]

    rng_state <- set_seed(seed)

    # Keep original seed generation for snapshot test compatibility
    sim_seeds <- sample(x = seq_len(1e5), size = nsim)

    run_sim <- function(iter_sim) {
      set.seed(sim_seeds[iter_sim])

      current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

      dle_with_args <- function(dose) {
        do.call(
          trueDLE,
          c(dose, as.list(current_args)[dle_arg_names])
        )
      }

      eff_with_args <- function(dose) {
        do.call(
          trueEff,
          c(dose, as.list(current_args)[eff_arg_names])
        )
      }

      data <- object@data
      sigma2 <- 1 / trueNu
      prob_placebo <- NULL
      mean_eff_placebo <- NULL

      if (data@placebo) {
        prob_placebo <- dle_with_args(object@data@doseGrid[1])
        mean_eff_placebo <- eff_with_args(object@data@doseGrid[1])
      }

      should_stop <- FALSE
      dose <- object@startingDose

      while (!should_stop) {
        prob <- dle_with_args(dose)
        mean_eff <- eff_with_args(dose)
        cohort_size <- size(object@cohort_size, dose = dose, data = data)

        cohort_size_placebo <- NULL
        if (data@placebo) {
          cohort_size_placebo <- size(
            object@pl_cohort_size,
            dose = dose,
            data = data
          )
        }

        if (firstSeparate && (cohort_size > 1L)) {
          dlts <- rbinom(n = 1L, size = 1L, prob = prob)
          eff_responses <- rnorm(n = 1L, mean = mean_eff, sd = sqrt(sigma2))

          dlts_placebo <- NULL
          eff_responses_placebo <- NULL
          if (data@placebo && (cohort_size_placebo > 0L)) {
            dlts_placebo <- rbinom(n = 1L, size = 1L, prob = prob_placebo)
            eff_responses_placebo <- rnorm(
              n = 1L,
              mean = mean_eff_placebo,
              sd = sqrt(sigma2)
            )
          }

          if (dlts == 0) {
            remaining_dlts <- rbinom(
              n = cohort_size - 1L,
              size = 1L,
              prob = prob
            )
            remaining_eff <- rnorm(
              n = cohort_size - 1L,
              mean = mean_eff,
              sd = sqrt(sigma2)
            )
            dlts <- c(dlts, remaining_dlts)
            eff_responses <- c(eff_responses, remaining_eff)

            if (data@placebo && (cohort_size_placebo > 0L)) {
              remaining_dlts_placebo <- rbinom(
                n = cohort_size_placebo,
                size = 1L,
                prob = prob_placebo
              )
              remaining_eff_placebo <- rnorm(
                n = cohort_size_placebo,
                mean = mean_eff_placebo,
                sd = sqrt(sigma2)
              )
              dlts_placebo <- c(dlts_placebo, remaining_dlts_placebo)
              eff_responses_placebo <- c(
                eff_responses_placebo,
                remaining_eff_placebo
              )
            }
          }
        } else {
          dlts <- rbinom(n = cohort_size, size = 1L, prob = prob)
          eff_responses <- rnorm(
            n = cohort_size,
            mean = mean_eff,
            sd = sqrt(sigma2)
          )

          dlts_placebo <- NULL
          eff_responses_placebo <- NULL
          if (data@placebo && (cohort_size_placebo > 0L)) {
            dlts_placebo <- rbinom(
              n = cohort_size_placebo,
              size = 1L,
              prob = prob_placebo
            )
            eff_responses_placebo <- rnorm(
              n = cohort_size_placebo,
              mean = mean_eff_placebo,
              sd = sqrt(sigma2)
            )
          }
        }

        if (data@placebo && (cohort_size_placebo > 0L)) {
          data <- update(
            object = data,
            x = object@data@doseGrid[1],
            y = dlts_placebo,
            w = eff_responses_placebo,
            check = FALSE
          )
          data <- update(
            object = data,
            x = dose,
            y = dlts,
            w = eff_responses,
            new_cohort = FALSE
          )
        } else {
          data <- update(object = data, x = dose, y = dlts, w = eff_responses)
        }

        dle_model <- update(object = object@model, data = data)
        eff_model <- update(object = object@eff_model, data = data)

        eff_nu <- eff_model@nu
        eff_sigma2 <- if (eff_model@use_fixed) {
          1 / eff_nu
        } else {
          1 / (as.numeric(eff_nu["a"] / eff_nu["b"]))
        }

        dose_limit <- maxDose(object@increments, data = data)

        next_best_result <- nextBest(
          object@nextBest,
          doselimit = dose_limit,
          model = dle_model,
          data = data,
          model_eff = eff_model,
          in_sim = TRUE
        )

        dose <- next_best_result$next_dose
        td_target_during_trial <- next_best_result$dose_target_drt
        td_target_during_trial_at_dose_grid <- next_best_result$next_dose_drt
        td_target_end_of_trial <- next_best_result$dose_target_eot
        td_target_end_of_trial_at_dose_grid <- next_best_result$next_dose_eot
        gstar <- next_best_result$dose_max_gain
        gstar_at_dose_grid <- next_best_result$next_dose_max_gain

        recommend <- min(
          td_target_end_of_trial_at_dose_grid,
          gstar_at_dose_grid
        )

        ci_tdeot <- list(
          lower = next_best_result$ci_dose_target_eot[1],
          upper = next_best_result$ci_dose_target_eot[2]
        )
        ratio_tdeot <- next_best_result$ci_ratio_dose_target_eot

        ci_gstar <- list(
          lower = next_best_result$ci_dose_max_gain[1],
          upper = next_best_result$ci_dose_max_gain[2]
        )
        ratio_gstar <- next_best_result$ci_ratio_dose_max_gain

        optimal_dose <- min(gstar, td_target_end_of_trial)

        if (optimal_dose == gstar) {
          ratio <- ratio_gstar
          ci <- ci_gstar
        } else {
          ratio <- ratio_tdeot
          ci <- ci_tdeot
        }

        should_stop <- stopTrial(
          object@stopping,
          dose = dose,
          model = dle_model,
          data = data,
          Effmodel = eff_model
        )
        stopit_results <- h_unpack_stopit(should_stop)
      }

      prob_fun <- probFunction(
        dle_model,
        phi1 = dle_model@phi1,
        phi2 = dle_model@phi2
      )
      dle_fit <- list(
        phi1 = dle_model@phi1,
        phi2 = dle_model@phi2,
        probDLE = prob_fun(object@data@doseGrid)
      )

      eff_fun <- efficacyFunction(
        eff_model,
        theta1 = eff_model@theta1,
        theta2 = eff_model@theta2
      )
      eff_fit <- list(
        theta1 = eff_model@theta1,
        theta2 = eff_model@theta2,
        ExpEff = eff_fun(object@data@doseGrid)
      )

      list(
        data = data,
        dose = dose,
        TDtargetDuringTrial = td_target_during_trial,
        TDtargetDuringTrialAtDoseGrid = td_target_during_trial_at_dose_grid,
        TDtargetEndOfTrial = td_target_end_of_trial,
        TDtargetEndOfTrialAtDoseGrid = td_target_end_of_trial_at_dose_grid,
        Gstar = gstar,
        GstarAtDoseGrid = gstar_at_dose_grid,
        Recommend = recommend,
        OptimalDose = optimal_dose,
        OptimalDoseAtDoseGrid = recommend,
        ratio = ratio,
        CI = ci,
        ratioGstar = ratio_gstar,
        CIGstar = ci_gstar,
        ratioTDEOT = ratio_tdeot,
        CITDEOT = ci_tdeot,
        fitDLE = dle_fit,
        fitEff = eff_fit,
        sigma2est = eff_sigma2,
        stop = attr(should_stop, "message"),
        report_results = stopit_results
      )
    }

    result_list <- get_result_list(
      fun = run_sim,
      nsim = nsim,
      vars = c(
        "sim_seeds",
        "args",
        "n_args",
        "firstSeparate",
        "trueDLE",
        "trueEff",
        "trueNu",
        "object"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    data_list <- lapply(result_list, "[[", "data")
    recommended_doses <- as.numeric(sapply(result_list, "[[", "Recommend"))

    td_target_during_trial_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetDuringTrial"
    ))

    td_target_end_of_trial_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrial"
    ))

    td_target_during_trial_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetDuringTrialAtDoseGrid"
    ))

    td_target_end_of_trial_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "TDtargetEndOfTrialAtDoseGrid"
    ))

    gstar_list <- as.numeric(sapply(result_list, "[[", "Gstar"))
    gstar_at_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "GstarAtDoseGrid"
    ))

    optimal_dose_list <- as.numeric(sapply(result_list, "[[", "OptimalDose"))
    optimal_dose_at_dose_grid_list <- as.numeric(sapply(
      result_list,
      "[[",
      "Recommend"
    ))

    ci_list <- lapply(result_list, "[[", "CI")
    ratio_list <- as.numeric(sapply(result_list, "[[", "ratio"))
    ci_tdeot_list <- lapply(result_list, "[[", "CITDEOT")
    ratio_tdeot_list <- as.numeric(sapply(result_list, "[[", "ratioTDEOT"))
    ci_gstar_list <- lapply(result_list, "[[", "CIGstar")
    ratio_gstar_list <- as.numeric(sapply(result_list, "[[", "ratioGstar"))

    fit_dle_list <- lapply(result_list, "[[", "fitDLE")
    fit_eff_list <- lapply(result_list, "[[", "fitEff")
    sigma2_estimates <- as.numeric(sapply(result_list, "[[", "sigma2est"))
    stop_reasons <- lapply(result_list, "[[", "stop")

    stop_results <- lapply(result_list, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))

    PseudoDualSimulations(
      data = data_list,
      doses = recommended_doses,
      final_td_target_during_trial_estimates = td_target_during_trial_list,
      final_td_target_end_of_trial_estimates = td_target_end_of_trial_list,
      final_td_target_during_trial_at_dose_grid = td_target_during_trial_dose_grid_list,
      final_td_target_end_of_trial_at_dose_grid = td_target_end_of_trial_dose_grid_list,
      final_cis = ci_list,
      final_ratios = ratio_list,
      final_gstar_estimates = gstar_list,
      final_gstar_at_dose_grid = gstar_at_dose_grid_list,
      final_gstar_cis = ci_gstar_list,
      final_gstar_ratios = ratio_gstar_list,
      final_tdeot_cis = ci_tdeot_list,
      final_tdeot_ratios = ratio_tdeot_list,
      final_optimal_dose = optimal_dose_list,
      final_optimal_dose_at_dose_grid = optimal_dose_at_dose_grid_list,
      fit = fit_dle_list,
      fit_eff = fit_eff_list,
      sigma2_est = sigma2_estimates,
      stop_reasons = stop_reasons,
      stop_report = stop_report,
      seed = rng_state
    )
  }
)

## DualResponsesSamplesDesign ----

### h_simulate_flexi ----

h_simulate_flexi <- 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),
  ...
) {
  stopifnot(
    trueSigma2 > 0,
    trueSigma2betaW > 0,
    is.numeric(trueEff),
    length(trueEff) == length(object@data@doseGrid)
  )

  args <- as.data.frame(args)
  n_args <- max(nrow(args), 1L)

  # Get argument names (excluding the first one which is the dose)
  dle_arg_names <- names(formals(trueDLE))[-1]

  # Seed handling
  rng_state <- set_seed(seed)

  # Generate individual seeds for simulation runs
  sim_seeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

  # Function to run a single simulation with index "iter_sim"
  run_sim <- function(iter_sim) {
    # Set the seed for this run
    set.seed(sim_seeds[iter_sim])

    # Get current arguments (appropriately recycled)
    current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

    # DLE truth function with current arguments
    dle_with_args <- function(dose) {
      do.call(
        trueDLE,
        # First argument: the dose
        c(
          dose,
          # Following arguments
          current_args
        )
      )
    }

    # Efficacy truth function (fixed for EffFlexi)
    eff_truth <- trueEff

    # Start with the provided data
    data <- object@data

    # Trial control variables
    should_stop <- FALSE
    dose <- object@startingDose
    dose_pl <- object@data@doseGrid[1]

    # Start with specified variance parameters
    sigma2 <- trueSigma2
    sigma2_beta_w <- trueSigma2betaW

    # Main simulation loop
    while (!should_stop) {
      # Calculate probabilities and outcomes at current dose
      dle_prob <- dle_with_args(dose)
      dle_prob_pl <- dle_with_args(dose_pl)

      dose_index <- which(dose == data@doseGrid)
      mean_eff <- eff_truth[dose_index]
      mean_eff_pl <- eff_truth[1]

      # Determine cohort size
      cohort_size <- size(object@cohort_size, dose = dose, data = data)

      if (data@placebo) {
        placebo_size <- size(
          object@pl_cohort_size,
          dose = dose,
          data = data
        )
      }

      ## simulate DLTs: depends on whether we
      ## separate the first patient or not.
      if (firstSeparate && (cohort_size > 1L)) {
        ## dose the first patient
        dlts <- rbinom(
          n = 1L,
          size = 1L,
          prob = dle_prob
        )

        if (data@placebo && (placebo_size > 0L)) {
          dlts_pl <- rbinom(
            n = 1L,
            size = 1L,
            prob = dle_prob_pl
          )
        }

        eff_responses <- rnorm(
          n = 1L,
          mean = mean_eff,
          sd = sqrt(trueSigma2)
        )

        if (data@placebo && (placebo_size > 0L)) {
          eff_responses_pl <- rnorm(
            n = 1L,
            mean = mean_eff_pl,
            sd = sqrt(trueSigma2)
          )
        }

        # If no DLT in first patient, enroll remaining patients
        if (dlts == 0) {
          dlts <- c(
            dlts,
            rbinom(
              n = cohort_size - 1L,
              size = 1L,
              prob = dle_prob
            )
          )
          eff_responses <- c(
            eff_responses,
            rnorm(
              n = cohort_size - 1L,
              mean = mean_eff,
              sd = sqrt(trueSigma2)
            )
          )
          if (data@placebo && (placebo_size > 0L)) {
            dlts_pl <- c(
              dlts_pl,
              rbinom(
                n = placebo_size,
                size = 1L,
                prob = dle_prob_pl
              )
            )
            eff_responses_pl <- c(
              eff_responses_pl,
              rnorm(
                n = placebo_size,
                mean = mean_eff_pl,
                sd = sqrt(trueSigma2)
              )
            )
          }
        }
      } else {
        # Dose all patients directly
        dlts <- rbinom(
          n = cohort_size,
          size = 1L,
          prob = dle_prob
        )

        eff_responses <- rnorm(
          n = cohort_size,
          mean = mean_eff,
          sd = sqrt(trueSigma2)
        )
        if (data@placebo && (placebo_size > 0L)) {
          dlts_pl <- rbinom(
            n = placebo_size,
            size = 1L,
            prob = dle_prob_pl
          )
          eff_responses_pl <- rnorm(
            n = placebo_size,
            mean = mean_eff_pl,
            sd = sqrt(trueSigma2)
          )
        }
      }

      ## update the data with this placebo (if any) cohort and then with active dose
      if (data@placebo && (placebo_size > 0L)) {
        data <- update(
          object = data,
          x = object@data@doseGrid[1],
          y = dlts_pl,
          w = eff_responses_pl,
          check = FALSE
        )

        ## update the data with active dose
        data <- update(
          object = data,
          x = dose,
          y = dlts,
          w = eff_responses,
          new_cohort = FALSE
        )
      } else {
        ## update the data with this cohort
        data <- update(
          object = data,
          x = dose,
          y = dlts,
          w = eff_responses
        )
      }

      # Update models with new data
      dle_model <- update(
        object = object@model,
        data = data
      )

      eff_model <- update(
        object = object@eff_model,
        data = data
      )

      # Calculate dose limit
      dose_limit <- maxDose(object@increments, data = data)

      # Generate MCMC samples from both models
      dle_samples <- mcmc(
        data = data,
        model = dle_model,
        options = mcmcOptions
      )

      eff_samples <- mcmc(
        data = data,
        model = eff_model,
        options = mcmcOptions
      )

      # Update variance estimates from MCMC samples
      sigma2 <- mean(eff_samples@data$sigma2W)
      sigma2_beta_w <- mean(eff_samples@data$sigma2betaW)

      # Calculate next best dose
      next_bd <- nextBest(
        object@nextBest,
        doselimit = dose_limit,
        samples = dle_samples,
        model = dle_model,
        model_eff = eff_model,
        samples_eff = eff_samples,
        data = data,
        in_sim = TRUE
      )

      # Extract dose recommendations
      dose <- next_bd$next_dose
      td_target_during_trial <- next_bd$dose_target_drt
      td_target_during_trial_at_dose_grid <- next_bd$next_dose_drt
      td_target_end_of_trial <- next_bd$dose_target_eot
      td_target_end_of_trial_at_dose_grid <- next_bd$next_dose_eot
      gstar <- next_bd$dose_max_gain
      gstar_at_dose_grid <- next_bd$next_dose_max_gain

      recommend <- min(
        td_target_end_of_trial_at_dose_grid,
        gstar_at_dose_grid
      )

      # Calculate 95% confidence intervals and ratios
      ci_tdeot <- list(
        lower = next_bd$ci_dose_target_eot[1],
        upper = next_bd$ci_dose_target_eot[2]
      )
      ratio_tdeot <- next_bd$ci_ratio_dose_target_eot

      ci_gstar <- list(
        lower = next_bd$ci_dose_max_gain[1],
        upper = next_bd$ci_dose_max_gain[2]
      )
      ratio_gstar <- next_bd$ci_ratio_dose_max_gain

      # Find the optimal dose
      optimal_dose <- min(gstar, td_target_end_of_trial)

      if (optimal_dose == gstar) {
        ratio <- ratio_gstar
        ci <- ci_gstar
      } else {
        ratio <- ratio_tdeot
        ci <- ci_tdeot
      }

      # Evaluate stopping rules
      should_stop <- stopTrial(
        object@stopping,
        dose = dose,
        samples = dle_samples,
        model = dle_model,
        data = data,
        TDderive = object@nextBest@derive,
        Effmodel = eff_model,
        Effsamples = eff_samples,
        Gstarderive = object@nextBest@mg_derive
      )
      stop_results <- h_unpack_stopit(should_stop)
    }

    # Calculate final model fits
    dle_fit <- fit(
      object = dle_samples,
      model = dle_model,
      data = data
    )

    eff_fit <- fit(
      object = eff_samples,
      model = eff_model,
      data = data
    )

    # Return simulation results
    list(
      data = data,
      dose = dose,
      TDtargetDuringTrial = td_target_during_trial,
      TDtargetDuringTrialAtDoseGrid = td_target_during_trial_at_dose_grid,
      TDtargetEndOfTrial = td_target_end_of_trial,
      TDtargetEndOfTrialAtDoseGrid = td_target_end_of_trial_at_dose_grid,
      Gstar = gstar,
      GstarAtDoseGrid = gstar_at_dose_grid,
      Recommend = recommend,
      OptimalDose = optimal_dose,
      OptimalDoseAtDoseGrid = recommend,
      ratio = ratio,
      CI = ci,
      ratioGstar = ratio_gstar,
      CIGstar = ci_gstar,
      ratioTDEOT = ratio_tdeot,
      CITDEOT = ci_tdeot,
      fitDLE = subset(dle_fit, select = c(middle, lower, upper)),
      fitEff = subset(eff_fit, select = c(middle, lower, upper)),
      sigma2est = sigma2,
      sigma2betaWest = sigma2_beta_w,
      stop = attr(should_stop, "message"),
      report_results = stop_results
    )
  }

  result_list <- get_result_list(
    fun = run_sim,
    nsim = nsim,
    vars = c(
      "sim_seeds",
      "args",
      "n_args",
      "firstSeparate",
      "trueDLE",
      "trueEff",
      "trueSigma2",
      "trueSigma2betaW",
      "object",
      "mcmcOptions"
    ),
    parallel = parallel,
    n_cores = nCores
  )

  # Process simulation results
  data_list <- lapply(result_list, "[[", "data")
  recommended_doses <- as.numeric(sapply(result_list, "[[", "Recommend"))

  # Extract model fits and variance estimates
  fit_dle_list <- lapply(result_list, "[[", "fitDLE")
  fit_eff_list <- lapply(result_list, "[[", "fitEff")
  sigma2_estimates <- as.numeric(sapply(result_list, "[[", "sigma2est"))
  sigma2_beta_w_estimates <- as.numeric(sapply(
    result_list,
    "[[",
    "sigma2betaWest"
  ))

  # Extract TD target estimates
  td_target_during_trial_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetDuringTrial"
  ))

  td_target_end_of_trial_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetEndOfTrial"
  ))

  td_target_during_trial_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetDuringTrialAtDoseGrid"
  ))

  td_target_end_of_trial_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetEndOfTrialAtDoseGrid"
  ))

  # Extract Gstar and optimal dose estimates
  gstar_list <- as.numeric(sapply(result_list, "[[", "Gstar"))

  gstar_at_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "GstarAtDoseGrid"
  ))

  optimal_dose_list <- as.numeric(sapply(result_list, "[[", "OptimalDose"))

  optimal_dose_at_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "Recommend"
  ))

  # Extract confidence intervals and ratios
  ci_list <- lapply(result_list, "[[", "CI")

  ratio_list <- as.numeric(sapply(result_list, "[[", "ratio"))

  ci_tdeot_list <- lapply(result_list, "[[", "CITDEOT")

  ratio_tdeot_list <- as.numeric(sapply(result_list, "[[", "ratioTDEOT"))

  ci_gstar_list <- lapply(result_list, "[[", "CIGstar")

  ratio_gstar_list <- as.numeric(sapply(result_list, "[[", "ratioGstar"))

  # Extract stopping information
  stop_reasons <- lapply(result_list, "[[", "stop")

  stop_results <- lapply(result_list, "[[", "report_results")
  stop_report <- as.matrix(do.call(rbind, stop_results))

  # Return simulation results
  PseudoDualFlexiSimulations(
    data = data_list,
    doses = recommended_doses,
    final_td_target_during_trial_estimates = td_target_during_trial_list,
    final_td_target_end_of_trial_estimates = td_target_end_of_trial_list,
    final_td_target_during_trial_at_dose_grid = td_target_during_trial_dose_grid_list,
    final_td_target_end_of_trial_at_dose_grid = td_target_end_of_trial_dose_grid_list,
    final_cis = ci_list,
    final_ratios = ratio_list,
    final_gstar_estimates = gstar_list,
    final_gstar_at_dose_grid = gstar_at_dose_grid_list,
    final_gstar_cis = ci_gstar_list,
    final_gstar_ratios = ratio_gstar_list,
    final_tdeot_cis = ci_tdeot_list,
    final_tdeot_ratios = ratio_tdeot_list,
    final_optimal_dose = optimal_dose_list,
    final_optimal_dose_at_dose_grid = optimal_dose_at_dose_grid_list,
    fit = fit_dle_list,
    fit_eff = fit_eff_list,
    sigma2_est = sigma2_estimates,
    sigma2_beta_w_est = sigma2_beta_w_estimates,
    stop_reasons = stop_reasons,
    stop_report = stop_report,
    seed = rng_state
  )
}

### h_simulate_nonflexi ----

h_simulate_nonflexi <- 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),
  ...
) {
  stopifnot(
    trueNu > 0,
    is.function(trueEff)
  )

  args <- as.data.frame(args)
  n_args <- max(nrow(args), 1L)

  # Get argument names (excluding the first one which is the dose)
  dle_arg_names <- names(formals(trueDLE))[-1]
  eff_arg_names <- names(formals(trueEff))[-1]

  # Seed handling
  rng_state <- set_seed(seed)

  # Generate individual seeds for simulation runs
  sim_seeds <- sample(x = seq_len(1e5), size = nsim)

  # Function to run a single simulation with index "iter_sim"
  run_sim <- function(iter_sim) {
    # Set the seed for this run
    set.seed(sim_seeds[iter_sim])

    # Get current arguments (appropriately recycled)
    current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

    # DLE truth function with current arguments
    dle_with_args <- 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(current_args)[dle_arg_names]
        )
      )
    }

    # Efficacy truth function with current arguments
    eff_with_args <- 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(current_args)[eff_arg_names]
        )
      )
    }

    # Find true sigma2 to generate responses
    true_sigma2 <- 1 / trueNu

    # Start with the provided data
    data <- object@data

    # Trial control variables
    should_stop <- FALSE
    dose <- object@startingDose

    # Main simulation loop
    while (!should_stop) {
      # Calculate probabilities and outcomes at current dose
      dle_prob <- dle_with_args(dose)
      mean_eff <- eff_with_args(dose)

      # Determine cohort size
      cohort_size <- size(object@cohort_size, dose = dose, data = data)

      if (data@placebo) {
        placebo_size <- size(
          object@pl_cohort_size,
          dose = dose,
          data = data
        )
        dose_pl <- data@doseGrid[1]
        dle_prob_pl <- dle_with_args(dose_pl)
        mean_eff_pl <- eff_with_args(dose_pl)
      }

      ## simulate DLTs: depends on whether we
      ## separate the first patient or not.
      if (firstSeparate && (cohort_size > 1L)) {
        # Dose the first patient
        dlts <- rbinom(
          n = 1L,
          size = 1L,
          prob = dle_prob
        )

        if (data@placebo && (placebo_size > 0L)) {
          dlts_pl <- rbinom(
            n = 1L,
            size = 1L,
            prob = dle_prob_pl
          )
        }

        eff_responses <- rnorm(
          n = 1L,
          mean = mean_eff,
          sd = sqrt(true_sigma2)
        )

        if (data@placebo && (placebo_size > 0L)) {
          eff_responses_pl <- rnorm(
            n = 1L,
            mean = mean_eff_pl,
            sd = sqrt(true_sigma2)
          )
        }

        # If there is no DLT, enroll the remaining patients
        if (dlts == 0) {
          dlts <- c(
            dlts,
            rbinom(
              n = cohort_size - 1L,
              size = 1L,
              prob = dle_prob
            )
          )
          eff_responses <- c(
            eff_responses,
            rnorm(
              n = cohort_size - 1L,
              mean = mean_eff,
              sd = sqrt(true_sigma2)
            )
          )

          if (data@placebo && (placebo_size > 0L)) {
            dlts_pl <- c(
              dlts_pl,
              rbinom(
                n = placebo_size,
                size = 1L,
                prob = dle_prob_pl
              )
            )
            eff_responses_pl <- c(
              mean_eff_pl,
              rnorm(
                n = placebo_size,
                mean = mean_eff_pl,
                sd = sqrt(true_sigma2)
              )
            )
          }
        }
      } else {
        # Directly dose all patients
        dlts <- rbinom(
          n = cohort_size,
          size = 1L,
          prob = dle_prob
        )
        eff_responses <- rnorm(
          n = cohort_size,
          mean = mean_eff,
          sd = sqrt(true_sigma2)
        )

        if (data@placebo && (placebo_size > 0L)) {
          dlts_pl <- rbinom(
            n = placebo_size,
            size = 1L,
            prob = dle_prob_pl
          )
          eff_responses_pl <- rnorm(
            n = placebo_size,
            mean = mean_eff_pl,
            sd = sqrt(true_sigma2)
          )
        }
      }

      ## update the data with this placebo (if any) cohort and then with active dose
      if (data@placebo && (placebo_size > 0L)) {
        data <- update(
          object = data,
          x = object@data@doseGrid[1],
          y = dlts_pl,
          w = eff_responses_pl,
          check = FALSE
        )

        # Update the data with active dose
        data <- update(
          object = data,
          x = dose,
          y = dlts,
          w = eff_responses,
          new_cohort = FALSE
        )
      } else {
        # Update the data with this cohort
        data <- update(
          object = data,
          x = dose,
          y = dlts,
          w = eff_responses
        )
      }

      # Update models with new data
      dle_model <- update(
        object = object@model,
        data = data
      )

      eff_model <- update(
        object = object@eff_model,
        data = data
      )

      nu <- eff_model@nu

      dle_samples <- mcmc(
        data = data,
        model = dle_model,
        options = mcmcOptions
      )

      eff_samples <- mcmc(
        data = data,
        model = eff_model,
        options = mcmcOptions
      )

      sigma2 <- if (eff_model@use_fixed) {
        1 / nu
      } else {
        1 / (as.numeric(nu["a"] / nu["b"]))
      }

      # Calculate dose limit
      dose_limit <- maxDose(object@increments, data = data)

      # Calculate next best dose
      next_bd <- nextBest(
        object@nextBest,
        doselimit = dose_limit,
        samples = dle_samples,
        model = dle_model,
        data = data,
        model_eff = eff_model,
        samples_eff = eff_samples,
        in_sim = TRUE
      )

      # Extract dose recommendations
      dose <- next_bd$next_dose
      td_target_during_trial <- next_bd$dose_target_drt
      td_target_during_trial_at_dose_grid <- next_bd$next_dose_drt
      td_target_end_of_trial <- next_bd$dose_target_eot
      td_target_end_of_trial_at_dose_grid <- next_bd$next_dose_eot
      gstar <- next_bd$dose_max_gain
      gstar_at_dose_grid <- next_bd$next_dose_max_gain

      recommend <- min(
        td_target_end_of_trial_at_dose_grid,
        gstar_at_dose_grid
      )

      # Calculate 95% confidence intervals and ratios
      ci_tdeot <- list(
        lower = next_bd$ci_dose_target_eot[1],
        upper = next_bd$ci_dose_target_eot[2]
      )
      ratio_tdeot <- next_bd$ci_ratio_dose_target_eot

      ci_gstar <- list(
        lower = next_bd$ci_dose_max_gain[1],
        upper = next_bd$ci_dose_max_gain[2]
      )
      ratio_gstar <- next_bd$ci_ratio_dose_max_gain

      # Find the optimal dose
      optimal_dose <- min(gstar, td_target_end_of_trial)

      if (optimal_dose == gstar) {
        ratio <- ratio_gstar
        ci <- ci_gstar
      } else {
        ratio <- ratio_tdeot
        ci <- ci_tdeot
      }

      # Evaluate stopping rules
      should_stop <- stopTrial(
        object@stopping,
        dose = dose,
        samples = dle_samples,
        model = dle_model,
        data = data,
        TDderive = object@nextBest@derive,
        Effmodel = eff_model,
        Effsamples = eff_samples,
        Gstarderive = object@nextBest@mg_derive
      )
      stop_results <- h_unpack_stopit(should_stop)
    }
    # Calculate final model fits
    dle_fit <- fit(
      object = dle_samples,
      model = dle_model,
      data = data
    )

    eff_fit <- fit(
      object = eff_samples,
      model = eff_model,
      data = data
    )

    # Return simulation results
    list(
      data = data,
      dose = dose,
      TDtargetDuringTrial = td_target_during_trial,
      TDtargetDuringTrialAtDoseGrid = td_target_during_trial_at_dose_grid,
      TDtargetEndOfTrial = td_target_end_of_trial,
      TDtargetEndOfTrialAtDoseGrid = td_target_end_of_trial_at_dose_grid,
      Gstar = gstar,
      GstarAtDoseGrid = gstar_at_dose_grid,
      Recommend = recommend,
      OptimalDose = optimal_dose,
      OptimalDoseAtDoseGrid = recommend,
      ratio = ratio,
      CI = ci,
      ratioGstar = ratio_gstar,
      CIGstar = ci_gstar,
      ratioTDEOT = ratio_tdeot,
      CITDEOT = ci_tdeot,
      fitDLE = subset(dle_fit, select = c(middle, lower, upper)),
      fitEff = subset(eff_fit, select = c(middle, lower, upper)),
      sigma2est = sigma2,
      stop = attr(
        should_stop,
        "message"
      ),
      report_results = stop_results
    )
  }

  result_list <- get_result_list(
    fun = run_sim,
    nsim = nsim,
    vars = c(
      "sim_seeds",
      "args",
      "n_args",
      "firstSeparate",
      "trueDLE",
      "trueEff",
      "trueNu",
      "object"
    ),
    parallel = parallel,
    n_cores = nCores
  )

  # Process simulation results
  data_list <- lapply(result_list, "[[", "data")
  recommended_doses <- as.numeric(sapply(result_list, "[[", "Recommend"))

  # Extract TD target estimates
  td_target_during_trial_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetDuringTrial"
  ))

  td_target_end_of_trial_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetEndOfTrial"
  ))

  td_target_during_trial_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetDuringTrialAtDoseGrid"
  ))

  td_target_end_of_trial_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "TDtargetEndOfTrialAtDoseGrid"
  ))

  # Extract Gstar and optimal dose estimates
  gstar_list <- as.numeric(sapply(result_list, "[[", "Gstar"))

  gstar_at_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "GstarAtDoseGrid"
  ))

  optimal_dose_list <- as.numeric(sapply(result_list, "[[", "OptimalDose"))

  optimal_dose_at_dose_grid_list <- as.numeric(sapply(
    result_list,
    "[[",
    "Recommend"
  ))

  # Extract confidence intervals and ratios
  ci_list <- lapply(result_list, "[[", "CI")
  ratio_list <- as.numeric(sapply(result_list, "[[", "ratio"))

  ci_tdeot_list <- lapply(result_list, "[[", "CITDEOT")
  ratio_tdeot_list <- as.numeric(sapply(result_list, "[[", "ratioTDEOT"))

  ci_gstar_list <- lapply(result_list, "[[", "CIGstar")
  ratio_gstar_list <- as.numeric(sapply(result_list, "[[", "ratioGstar"))

  # Extract model fits and variance estimates
  fit_dle_list <- lapply(result_list, "[[", "fitDLE")
  fit_eff_list <- lapply(result_list, "[[", "fitEff")
  sigma2_estimates <- as.numeric(sapply(result_list, "[[", "sigma2est"))

  # Extract stopping information
  stop_reasons <- lapply(result_list, "[[", "stop")

  stop_results <- lapply(result_list, "[[", "report_results")
  stop_report <- as.matrix(do.call(rbind, stop_results))

  # Return simulation results
  PseudoDualSimulations(
    data = data_list,
    doses = recommended_doses,
    final_td_target_during_trial_estimates = td_target_during_trial_list,
    final_td_target_end_of_trial_estimates = td_target_end_of_trial_list,
    final_td_target_during_trial_at_dose_grid = td_target_during_trial_dose_grid_list,
    final_td_target_end_of_trial_at_dose_grid = td_target_end_of_trial_dose_grid_list,
    final_cis = ci_list,
    final_ratios = ratio_list,
    final_gstar_estimates = gstar_list,
    final_gstar_at_dose_grid = gstar_at_dose_grid_list,
    final_gstar_cis = ci_gstar_list,
    final_gstar_ratios = ratio_gstar_list,
    final_tdeot_cis = ci_tdeot_list,
    final_tdeot_ratios = ratio_tdeot_list,
    final_optimal_dose = optimal_dose_list,
    final_optimal_dose_at_dose_grid = optimal_dose_at_dose_grid_list,
    fit = fit_dle_list,
    fit_eff = fit_eff_list,
    sigma2_est = sigma2_estimates,
    stop_reasons = stop_reasons,
    stop_report = stop_report,
    seed = rng_state
  )
}

### method definition ----

#' Simulate dose escalation procedure using DLE and efficacy responses with samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a method to simulate dose escalation procedure using both DLE and efficacy responses.
#' This is a method based on the [`DualResponsesSamplesDesign`] where DLE model used are of
#' [`ModelTox`] class object and efficacy model used are of [`ModelEff`]
#' class object (special case is [`EffFlexi`] class model object).
#' In addition, DLE and efficacy samples are involved or generated in the simulation
#' process.
#'
#' @param object the [`DualResponsesSamplesDesign`] object we want to
#'   simulate the data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param trueDLE (`function`)\cr 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 `args`.
#' @param trueEff (`function`)\cr a function which takes as input a dose (vector) and returns the expected
#'   efficacy responses (vector). Additional arguments can be supplied in `args`.
#' @param trueNu (`number`)\cr (not with [`EffFlexi`]) the precision, the inverse of the
#'   variance of the efficacy responses
#' @param trueSigma2 (`number`)\cr (only with [`EffFlexi`]) the true variance of the efficacy
#'   responses which must be a single positive scalar.
#' @param trueSigma2betaW (`number`)\cr (only with [`EffFlexi`]) the true variance for the
#'   random walk model used for smoothing. This must be a single positive scalar.
#' @param args (`data.frame`)\cr data frame with arguments for the `trueDLE` and
#'   `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 `nsim` simulations.
#' @param firstSeparate (`flag`)\cr 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 ([McmcOptions])\cr object of class [`McmcOptions`],
#'   giving the MCMC options for each evaluation in the trial. By default,
#'   the standard options are used
#' @param parallel (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param ... not used
#'
#' @return an object of class [`PseudoDualSimulations`] or
#'   [`PseudoDualFlexiSimulations`]
#'
#' @example examples/design-method-simulateDualResponsesSamplesDesign.R
#' @export
setMethod(
  f = "simulate",
  signature = signature(
    object = "DualResponsesSamplesDesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  definition = 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 validations
    assert_function(trueDLE)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)

    # Check if special case applies
    is_flexi <- is(object@eff_model, "EffFlexi")

    # Dispatch to appropriate helper based on model type
    if (is_flexi) {
      h_simulate_flexi(
        object = object,
        nsim = nsim,
        seed = seed,
        trueDLE = trueDLE,
        trueEff = trueEff,
        trueSigma2 = trueSigma2,
        trueSigma2betaW = trueSigma2betaW,
        args = args,
        firstSeparate = firstSeparate,
        mcmcOptions = mcmcOptions,
        parallel = parallel,
        nCores = nCores
      )
    } else {
      h_simulate_nonflexi(
        object = object,
        nsim = nsim,
        seed = seed,
        trueDLE = trueDLE,
        trueEff = trueEff,
        trueNu = trueNu,
        args = args,
        firstSeparate = firstSeparate,
        mcmcOptions = mcmcOptions,
        parallel = parallel,
        nCores = nCores
      )
    }
  }
)

## DADesign ----

#' Simulate outcomes from a time-to-DLT augmented CRM design
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This method simulates dose escalation trials using time-to-DLT data,
#' where the timing of dose-limiting toxicities is explicitly modeled.
#'
#' @param object the [`DADesign`] object we want to simulate data from
#' @param nsim (`count`)\cr the number of simulations (default: 1)
#' @param seed see [set_seed()]
#' @param truthTox (`function`)\cr 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 `args`.
#' @param truthSurv (`function`)\cr 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 than `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`)\cr data frame with arguments for the `truthTox` function. 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. In order to produce outcomes from the posterior predictive
#'   distribution, e.g, pass an `object` that contains the data observed so
#'   far, `truthTox` contains the `prob` function from the model in
#'   `object`, and `args` contains posterior samples from the model.
#' @param firstSeparate (`flag`)\cr 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 (`flag`)\cr allow deescalation when a DLT occurs in cohorts with lower dose
#'   level? (default: TRUE)
#' @param mcmcOptions ([McmcOptions])\cr object of class [`McmcOptions`],
#'   giving the MCMC options for each evaluation in the trial. By default,
#'   the standard options are used.
#' @param DA (`flag`)\cr use dose-adaptation rules? (default: TRUE)
#' @param parallel (`flag`)\cr should the simulation runs be parallelized across the
#'   clusters of the computer? (not default)
#' @param nCores (`count`)\cr how many cores should be used for parallel computing?
#'   Defaults to the number of cores on the machine, maximum 5.
#' @param derive (`list`)\cr 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.
#' @param ... not used
#'
#' @return an object of class [`Simulations`]
#'
#' @note Backfill cohorts are not yet implemented and therefore will lead to an error if used
#'   in the `DADesign` object.
#'
#' @example examples/design-method-simulate-DADesign.R
#' @export
setMethod(
  f = "simulate",
  signature = signature(
    object = "DADesign",
    nsim = "ANY",
    seed = "ANY"
  ),
  definition = 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(),
    ...
  ) {
    # Validate inputs
    assert_function(truthTox)
    assert_function(truthSurv)
    assert_flag(firstSeparate)
    assert_count(nsim, positive = TRUE)
    assert_flag(parallel)
    assert_count(nCores, positive = TRUE)
    assert_class(object@backfill@opening, "OpeningNone")

    args <- as.data.frame(args)
    n_args <- max(nrow(args), 1L)

    # Seed handling
    rng_state <- set_seed(seed)

    # Generate individual seeds for simulation runs
    sim_seeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

    # Define inverse function for DLT survival generation.
    inverse <- function(f, lower = -100, upper = 100) {
      function(y) {
        uniroot((function(x) f(x) - y), lower = lower, upper = upper)[1]$root
      }
    }

    # Get DLT window length.
    data <- object@data
    t_max <- data@Tmax

    if (is.null(trueTmax)) {
      trueTmax <- t_max
    } else if (trueTmax < t_max) {
      warning("trueTmax < Tmax! trueTmax is set to Tmax")
      trueTmax <- t_max
    }

    # Calculate the inverse function of survival to DLT CDF.
    inverse_truth_surv <- inverse(truthSurv, 0, trueTmax)

    # Generate random survival times for DLT data.
    # Returns t_max when no DLT occurs.
    generate_surv_times <- function(
      dlt,
      t_max,
      inverse_surv = inverse_truth_surv
    ) {
      surv_times <- rep(-100, length(dlt))

      if (sum(dlt == 0) > 0) {
        surv_times[dlt == 0] <- t_max
      }

      if (sum(dlt == 1) > 0) {
        surv_times[dlt == 1] <- unlist(lapply(
          runif(sum(dlt == 1), 0, 1),
          inverse_surv
        ))
      }

      # Ensure results are always positive.
      surv_times[surv_times <= 0] <- 0.05
      surv_times
    }

    # Check if follow-up requirements are fulfilled for opening next cohort.
    ready_to_open <- function(day, window, surv_times) {
      cohort_size <- length(surv_times)
      # Calculate when patients start.
      start_time <- apply(
        rbind(surv_times[-cohort_size], window$patientGap[-1]),
        2,
        min
      )
      # Calculate relative time for each patient on the specified day.
      individual_check <- day - cumsum(c(0, start_time))
      # Ensure minimum is 0.
      individual_check[individual_check < 0] <- 0
      follow_up <- apply(rbind(surv_times, individual_check), 2, min)

      all(
        (follow_up -
          apply(rbind(window$patientFollow, surv_times), 2, min)) >=
          0
      ) &
        (max(follow_up) >= min(window$patientFollowMin, max(surv_times)))
    }

    # Determine when to open the next cohort.
    # Assumes sufficient patients are available for immediate enrollment.
    next_open <- function(window, surv_times) {
      cohort_size <- length(surv_times)

      window$patientGap <- window$patientGap[1:cohort_size]
      # If DLT happens before end of DLT window, next cohort opens earlier.
      start_time <- apply(
        rbind(surv_times[-cohort_size], window$patientGap[-1]),
        2,
        min
      )
      # Duration until all DLT windows finished.
      max_time <- max(surv_times + cumsum(c(0, start_time)))

      requirements_met <- sapply(1:max_time, function(i) {
        ready_to_open(i, window, surv_times)
      })
      if (sum(requirements_met) > 0) {
        # Earliest time that requirements are met.
        time <- min(c(1:max_time)[requirements_met])
      } else {
        time <- max_time
      }
      time
    }

    # Function to run a single simulation.
    run_sim <- function(iter_sim) {
      # Set the seed for this run.
      set.seed(sim_seeds[iter_sim])

      # Get current arguments (appropriately recycled).
      current_args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]

      # Truth function with current arguments.
      truth_with_args <- function(dose) {
        do.call(
          truthTox,
          c(
            dose,
            current_args
          )
        )
      }

      # Start with the provided data.
      data <- object@data

      # Handle placebo if present.
      if (data@placebo) {
        prob_pl <- truth_with_args(object@data@doseGrid[1])
      }

      # Trial control variables.
      should_stop <- FALSE
      trial_time <- 0

      # Initialize observed DLT data.
      observed_dlts <- data@y
      observed_surv <- data@u
      observed_t0 <- data@t0

      # Initialize with starting dose.
      dose <- object@startingDose

      # Main simulation loop.
      while (!should_stop) {
        # Calculate toxicity probability at current dose.
        prob <- truth_with_args(dose)

        # Determine cohort size.
        cohort_size <- size(object@cohort_size, dose = dose, data = data)

        if (data@placebo) {
          placebo_size <- size(
            object@pl_cohort_size,
            dose = dose,
            data = data
          )
        }

        max_size <- if (data@placebo) {
          cohort_size + placebo_size
        } else {
          cohort_size
        }

        safety_window <- windowLength(object@safetyWindow, max_size)

        # Simulate DLTs for cohort.
        # If any patient has DLT before first patient finishes staggered window,
        # further enrollment will be stopped.
        h_generate_dlt_and_surv <- function(n, prob, start = NULL) {
          dlts <- rbinom(
            n = n,
            size = 1L,
            prob = prob
          )
          surv_times <- ceiling(generate_surv_times(
            dlts,
            trueTmax,
            inverse_surv = inverse_truth_surv
          ))

          if (!is.null(start)) {
            dlts <- c(start$dlts, dlts)
            surv_times <- c(start$surv, surv_times)
          }

          if (t_max < trueTmax) {
            dlts[dlts == 1 & surv_times > t_max] <- 0

            surv_times <- apply(
              rbind(surv_times, rep(t_max, length(surv_times))),
              2,
              min
            )
          }

          list(dlts = dlts, surv = surv_times)
        }

        # Update data with active and placebo cohorts.
        h_update_data_da <- function(active, placebo, time) {
          result <- update(
            object = data,
            y = c(observed_dlts, active$dlts),
            u = c(observed_surv, active$surv),
            t0 = c(observed_t0, cohort_t0),
            x = dose,
            trialtime = time
          )

          if (data@placebo) {
            result <- update(
              object = result,
              y = c(observed_dlts, active$dlts, placebo$dlts),
              u = c(observed_surv, active$surv, placebo$surv),
              t0 = c(
                observed_t0,
                cohort_t0,
                rep(cohort_t0[1], length(placebo$dlts))
              ),
              x = object@data@doseGrid[1],
              trialtime = time
            )
          }

          result
        }

        if (firstSeparate && (cohort_size > 1L)) {
          # Dose the first patient.
          active_dlt_surv <- h_generate_dlt_and_surv(1L, prob)
          placebo_dlt_surv <- if (data@placebo && (placebo_size > 0L)) {
            # If placebo, also dose one placebo patient.
            h_generate_dlt_and_surv(1L, prob_pl)
          } else {
            list()
          }

          cohort_t0 <- trial_time

          # Check if there are DLTs during safety window.
          temp_data <- h_update_data_da(
            active_dlt_surv,
            placebo_dlt_surv,
            trial_time + safety_window$patientGap[2]
          )
          temp_time <- (temp_data@u + temp_data@t0)[
            temp_data@y == 1 & temp_data@x <= dose
          ]

          # If no DLTs occur during safety window, enroll remaining patients.
          if (sum(temp_time > trial_time) == 0) {
            # Enroll the remaining patients.
            active_dlt_surv <- h_generate_dlt_and_surv(
              cohort_size - 1L,
              prob,
              start = active_dlt_surv
            )
            placebo_dlt_surv <- if (data@placebo && (placebo_size > 1L)) {
              h_generate_dlt_and_surv(
                placebo_size - 1L,
                prob_pl,
                start = placebo_dlt_surv
              )
            } else {
              list()
            }

            # Adjust for DLTs happening before end of safety window.
            real_window <- apply(
              rbind(
                c(active_dlt_surv$surv, placebo_dlt_surv$surv)[-cohort_size],
                safety_window$patientGap[-1]
              ),
              2,
              min
            )

            cohort_t0 <- trial_time + c(0, cumsum(real_window))
          }

          rm(temp_data)
          rm(temp_time)
        } else {
          # Directly dose all patients.
          active_dlt_surv <- h_generate_dlt_and_surv(
            cohort_size,
            prob
          )
          placebo_dlt_surv <- if (data@placebo) {
            h_generate_dlt_and_surv(
              placebo_size,
              prob_pl
            )
          } else {
            list()
          }

          # Adjust for DLTs happening before end of safety window.
          real_window <- apply(
            rbind(
              c(active_dlt_surv$surv, placebo_dlt_surv$surv)[-cohort_size],
              safety_window$patientGap[-1]
            ),
            2,
            min
          )

          cohort_t0 <- trial_time + c(0, cumsum(real_window))
        }

        # Update observed data with new cohort.
        old_dlts <- observed_dlts

        observed_dlts <- c(
          observed_dlts,
          placebo_dlt_surv$dlts,
          active_dlt_surv$dlts
        )

        observed_surv <- c(
          observed_surv,
          placebo_dlt_surv$surv,
          active_dlt_surv$surv
        )

        observed_t0 <- c(
          observed_t0,
          rep(cohort_t0[1], length(placebo_dlt_surv$dlts)),
          rep(cohort_t0, length.out = length(active_dlt_surv$dlts))
        )

        time_to_next <- next_open(
          window = safety_window,
          surv_times = c(placebo_dlt_surv$surv, active_dlt_surv$surv)
        )

        # Handle deescalation if DLTs occur in previous cohorts.
        if (deescalate == TRUE) {
          are_dlts_after_trial_start <- (observed_surv + observed_t0) >
            trial_time
          are_dlts_before_open_next_cohort <- (observed_surv +
            observed_t0 -
            trial_time) <=
            time_to_next
          are_dlts_happening <- observed_dlts == 1
          is_new_dlt <- (are_dlts_after_trial_start &
            are_dlts_before_open_next_cohort &
            are_dlts_happening)

          new_dlt_ids <- seq_along(observed_dlts)[is_new_dlt]
          last_id_previous_cohort <- length(old_dlts)
          is_new_dlt_in_previous_cohort <- new_dlt_ids <=
            last_id_previous_cohort

          new_dlt_ids <- new_dlt_ids[is_new_dlt_in_previous_cohort]

          if (length(new_dlt_ids) > 0) {
            for (this_new_dlt_id in new_dlt_ids) {
              this_new_dlt_time <- (observed_surv + observed_t0)[
                this_new_dlt_id
              ]

              # Identify patients at higher doses who are impacted.
              later_ids <- c(this_new_dlt_id:length(observed_dlts))
              all_doses <- c(data@x, rep(dose, length(active_dlt_surv$dlts)))
              this_new_dlt_dose <- all_doses[this_new_dlt_id]
              is_dose_higher_than_this_new_dlt_dose <- all_doses[later_ids] >
                this_new_dlt_dose
              ids_to_deescalate <- later_ids[
                is_dose_higher_than_this_new_dlt_dose
              ]

              if (length(ids_to_deescalate) > 0) {
                # DLT will be observed once follow-up time >= time to DLT.
                this_new_dlt_time_after_followup <- this_new_dlt_time >=
                  (observed_t0[ids_to_deescalate] +
                    observed_surv[ids_to_deescalate])
                observed_dlts[ids_to_deescalate] <- as.integer(
                  observed_dlts[ids_to_deescalate] *
                    this_new_dlt_time_after_followup
                )

                # Some patients in later cohorts may not be enrolled yet when new DLT occurs.
                # Remove those patients from the cohort.
                ids_not_enrolled <- ids_to_deescalate[
                  (observed_t0[ids_to_deescalate] >= this_new_dlt_time)
                ]

                ids_enrolled <- setdiff(
                  ids_to_deescalate,
                  ids_not_enrolled
                )

                # Update DLT-free survival time for already enrolled patients.
                if (length(ids_enrolled) > 0) {
                  surv_time <- pmin(
                    observed_surv[ids_enrolled],
                    this_new_dlt_time - observed_t0[ids_enrolled]
                  )
                  assert_true(all(surv_time >= 0))

                  observed_surv[ids_enrolled] <- surv_time
                }

                # Remove patients not yet enrolled.
                if (length(ids_not_enrolled) > 0) {
                  observed_surv <- observed_surv[-ids_not_enrolled]
                  observed_t0 <- observed_t0[-ids_not_enrolled]
                  observed_dlts <- observed_dlts[-ids_not_enrolled]
                }
              }
            }

            time_to_next <- min(
              time_to_next,
              max((observed_surv + observed_t0)[
                (length(old_dlts) + 1):length(observed_dlts)
              ]) -
                trial_time
            )
          }
        }

        # Update trial time.
        trial_time <- trial_time + time_to_next

        # Update data object with observations available when next cohort opens.
        if (data@placebo) {
          # First patients are from placebo.
          data <- update(
            object = data,
            y = head(observed_dlts, -length(active_dlt_surv$dlts)),
            u = head(observed_surv, -length(active_dlt_surv$surv)),
            t0 = head(observed_t0, -length(active_dlt_surv$surv)),
            x = object@data@doseGrid[1],
            trialtime = trial_time
          )
        }
        data <- update(
          object = data,
          y = observed_dlts,
          u = observed_surv,
          t0 = observed_t0,
          x = dose,
          trialtime = trial_time
        )

        try(
          if (
            length(data@x) != length(data@u) ||
              length(data@u) != length(data@y)
          ) {
            stop("x,y,u dimension error")
          }
        )

        # Calculate dose limit.
        dose_limit <- maxDose(object@increments, data = data)

        # Generate MCMC samples from model.
        if (DA == TRUE) {
          samples <- mcmc(
            data = data,
            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
          )

          truncated_data <- Data(
            x = data@x,
            y = data@y,
            doseGrid = data@doseGrid,
            cohort = data@cohort,
            ID = data@ID
          )

          samples <- mcmc(
            data = truncated_data,
            model = temp_model,
            options = mcmcOptions
          )
        }

        # Calculate next best dose.
        dose <- nextBest(
          object@nextBest,
          doselimit = dose_limit,
          samples = samples,
          model = object@model,
          data = data
        )$value

        # Evaluate stopping rules.
        should_stop <- stopTrial(
          object@stopping,
          dose = dose,
          samples = samples,
          model = object@model,
          data = data
        )
        stop_results <- h_unpack_stopit(should_stop)
      }

      # Calculate final model fit.
      fit_result <- fit(
        object = samples,
        model = object@model,
        data = data
      )

      # Get MTD estimate from samples.
      target_dose_samples <- dose(
        mean(object@nextBest@target),
        model = object@model,
        samples = samples
      )

      # Calculate additional statistics.
      additional_stats <- lapply(derive, function(f) f(target_dose_samples))

      # Return simulation results.
      list(
        data = data,
        dose = dose,
        duration = trial_time,
        fit = subset(fit_result, select = c(middle, lower, upper)),
        stop = attr(
          should_stop,
          "message"
        ),
        report_results = stop_results,
        additional_stats = additional_stats
      )
    }

    result_list <- get_result_list(
      fun = run_sim,
      nsim = nsim,
      vars = c(
        "sim_seeds",
        "args",
        "n_args",
        "firstSeparate",
        "truthTox",
        "truthSurv",
        "object",
        "mcmcOptions",
        "next_open",
        "ready_to_open"
      ),
      parallel = parallel,
      n_cores = nCores
    )

    # Process simulation results.
    data_list <- lapply(result_list, "[[", "data")
    recommended_doses <- as.numeric(sapply(result_list, "[[", "dose"))
    trial_duration <- as.numeric(sapply(result_list, "[[", "duration"))
    fit_list <- lapply(result_list, "[[", "fit")

    stop_reasons <- lapply(result_list, "[[", "stop")

    stop_results <- lapply(result_list, "[[", "report_results")
    stop_report <- as.matrix(do.call(rbind, stop_results))

    additional_stats <- lapply(result_list, "[[", "additional_stats")

    # Return simulation results.
    DASimulations(
      data = data_list,
      doses = recommended_doses,
      fit = fit_list,
      trial_duration = trial_duration,
      stop_report = stop_report,
      stop_reasons = stop_reasons,
      additional_stats = additional_stats,
      seed = rng_state
    )
  }
)

## 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
      )
    })
  }
)

# examine ----

#' Obtain Hypothetical Trial Course Table for a Design
#'
#' This generic function takes a design and generates a `data.frame`
#' showing the beginning of several hypothetical trial courses under
#' the design. This means, from the generated `data.frame` 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 ([`Design`] or [`RuleDesign`])\cr the design we want to examine
#' @param ... 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) {
    assert_count(maxNoIncrement, positive = TRUE)
    standardGeneric("examine")
  },
  valueClass = "data.frame"
)

## Design ----

#' @describeIn examine Examine a model-based CRM.
#'
#' @param mcmcOptions ([`McmcOptions`])\cr 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) {
    ret <- data.frame(
      dose = numeric(),
      DLTs = integer(),
      nextDose = numeric(),
      stop = logical(),
      increment = integer()
    )
    base_data <- object@data

    should_stop <- FALSE

    # Counter how many contiguous doses at 0 DLTs with no increment.
    no_increment_counter <- 0L

    # Initialize with starting dose.
    dose <- object@startingDose

    while (!should_stop) {
      # What is the cohort size at this dose?
      cohort_size <- size(object@cohort_size, dose = dose, data = base_data)

      if (base_data@placebo) {
        cohort_size_pl <- size(
          object@pl_cohort_size,
          dose = dose,
          data = base_data
        )
      }

      # For all possible number of DLTs:
      for (num_dlts in 0:cohort_size) {
        # Update data with corresponding DLT vector.
        if (base_data@placebo && (cohort_size_pl > 0L)) {
          data_updated <- update(
            object = base_data,
            x = base_data@doseGrid[1],
            y = rep(0, cohort_size_pl),
            check = FALSE
          )

          data_updated <- update(
            object = data_updated,
            x = dose,
            y = rep(
              x = c(0, 1),
              times = c(
                cohort_size - num_dlts,
                num_dlts
              )
            ),
            new_cohort = FALSE
          )
        } else {
          data_updated <- update(
            object = base_data,
            x = dose,
            y = rep(
              x = c(0, 1),
              times = c(
                cohort_size - num_dlts,
                num_dlts
              )
            )
          )
        }

        # Calculate dose limit.
        dose_limit <- maxDose(object@increments, data = data_updated)

        # Generate samples from the model.
        samples <- mcmc(
          data = data_updated,
          model = object@model,
          options = mcmcOptions
        )

        # Calculate next best dose.
        next_dose <- nextBest(
          object@nextBest,
          doselimit = dose_limit,
          samples = samples,
          model = object@model,
          data = data_updated
        )$value

        # Compute relative increment in percent.
        increment <- round((next_dose - dose) / dose * 100)

        # Evaluate stopping rules.
        stop_this_trial <- stopTrial(
          object@stopping,
          dose = next_dose,
          samples = samples,
          model = object@model,
          data = data_updated
        )

        # Append information to the data frame.
        ret <- rbind(
          ret,
          list(
            dose = dose,
            DLTs = num_dlts,
            nextDose = next_dose,
            stop = stop_this_trial,
            increment = as.integer(increment)
          )
        )
      }

      # Update base data.
      if (base_data@placebo && (cohort_size_pl > 0L)) {
        base_data <- update(
          object = base_data,
          x = base_data@doseGrid[1],
          y = rep(0, cohort_size_pl),
          check = FALSE
        )

        base_data <- update(
          object = base_data,
          x = dose,
          y = rep(0, cohort_size),
          new_cohort = FALSE
        )
      } else {
        base_data <- update(
          object = base_data,
          x = dose,
          y = rep(0, cohort_size)
        )
      }

      # Extract results if 0 DLTs.
      results_no_dlts <- subset(
        tail(ret, cohort_size + 1),
        dose == dose & DLTs == 0
      )

      # Determine new dose.
      new_dose <- as.numeric(results_no_dlts$nextDose)

      # Calculate difference to previous dose.
      dose_diff <- new_dose - dose

      # Update the counter for no increments of the dose.
      if (dose_diff == 0) {
        no_increment_counter <- no_increment_counter + 1L
      } else {
        no_increment_counter <- 0L
      }

      # Check if stopping rule would be fulfilled.
      stop_already <- results_no_dlts$stop

      # Update dose.
      dose <- new_dose

      # Check if too many times no increment.
      stop_no_increment <- (no_increment_counter >= maxNoIncrement)
      if (stop_no_increment) {
        warning(paste(
          "Stopping because",
          no_increment_counter,
          "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.
      should_stop <- (dose >= max(object@data@doseGrid)) ||
        stop_already ||
        stop_no_increment
    }
    ret
  }
)

## RuleDesign ----

#' @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.
    base_data <- object@data

    # Are we finished and can stop?
    should_stop <- FALSE

    # Counter: contiguous doses at 0 DLTs with no increment.
    no_increment_counter <- 0L

    # Initialize with starting dose.
    dose <- object@startingDose

    # Continue filling up the table until stopping.
    while (!should_stop) {
      # Cohort size at this dose.
      cohort_size <- size(object@cohort_size, dose = dose, data = base_data)

      # For all possible number of DLTs.
      for (num_dlts in 0:cohort_size) {
        # Update data with corresponding DLT vector.
        data_updated <- update(
          object = base_data,
          x = dose,
          y = rep(
            x = c(0, 1),
            times = c(
              cohort_size - num_dlts,
              num_dlts
            )
          )
        )

        # Evaluate the rule.
        outcome <- nextBest(object@nextBest, data = data_updated)

        # Next dose and whether to stop here.
        next_dose <- outcome$value
        stop_this_trial <- outcome$stopHere

        # Compute relative increment in percent.
        increment <- round((next_dose - dose) / dose * 100)

        # Append information to the data frame.
        ret <- rbind(
          ret,
          list(
            dose = dose,
            DLTs = num_dlts,
            nextDose = next_dose,
            stop = stop_this_trial,
            increment = as.integer(increment)
          )
        )
      }

      # Change base data.
      base_data <- update(
        object = base_data,
        x = dose,
        y = rep(0, cohort_size)
      )

      # Results if 0 DLTs.
      results_no_dlts <- subset(
        tail(ret, cohort_size + 1),
        dose == dose & DLTs == 0
      )

      # New dose and difference to previous dose.
      new_dose <- as.numeric(results_no_dlts$nextDose)
      dose_diff <- new_dose - dose

      # Update the counter for no increments of the dose.
      if (dose_diff == 0) {
        no_increment_counter <- no_increment_counter + 1L
      } else {
        no_increment_counter <- 0L
      }

      # Would stopping rule be fulfilled already?
      stop_already <- results_no_dlts$stop

      # Update dose.
      dose <- new_dose

      # Too many times no increment?
      stop_no_increment <- (no_increment_counter >= maxNoIncrement)
      if (stop_no_increment) {
        warning(paste(
          "Stopping because",
          no_increment_counter,
          "times no increment vs. previous dose"
        ))
      }

      # Check if we can stop:
      # highest dose reached next cohort, stopping rule fulfilled, or too many no-increment.
      should_stop <- (dose >= max(object@data@doseGrid)) ||
        stop_already ||
        stop_no_increment
    }

    ret
  }
)

## DADesign ----

#' @describeIn examine Examine a model-based CRM.
#'
#' @param mcmcOptions ([`McmcOptions`])\cr
#'   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) {
    # Check follow-up sufficiency (TRUE/FALSE);
    ready_to_open <- function(day, window, this_surv) {
      size <- length(this_surv)
      start_time <- apply(
        rbind(this_surv[-size], window$patientGap[-1]),
        2,
        min
      )
      individual_check <- day - cumsum(c(0, start_time))
      individual_check[individual_check < 0] <- 0
      follow_up <- apply(rbind(this_surv, individual_check), 2, min)
      all(
        (follow_up - apply(rbind(window$patientFollow, this_surv), 2, min)) >= 0
      ) &&
        (max(follow_up) >= min(window$patientFollowMin, max(this_surv)))
    }

    # Determine when to open the next cohort; applies to all trials.
    next_open <- function(window, this_surv) {
      size <- length(this_surv)
      window$patientGap <- window$patientGap[1:size]
      start_time <- apply(
        rbind(this_surv[-size], window$patientGap[-1]),
        2,
        min
      )
      max_t <- max(this_surv + cumsum(c(0, start_time)))

      met <- sapply(1:max_t, function(i) ready_to_open(i, window, this_surv))
      if (sum(met) > 0) min(c(1:max_t)[met]) else max_t
    }

    # Initialize result table.
    ret <- data.frame(
      DLTsearly_1 = integer(),
      dose = numeric(),
      DLTs = integer(),
      nextDose = numeric(),
      stop = logical(),
      increment = integer()
    )

    # Base data and trial state.
    base_data <- object@data
    should_stop <- FALSE
    dose <- object@startingDose

    # Observed facts trackers (cumulative across cohorts).
    observed_dlts <- base_data@y
    observed_surv <- base_data@u
    observed_t0 <- base_data@t0

    # Global trial clock and previous cohort timing.
    trial_time <- 0
    prev_time <- 0

    # DLT window length.
    t_max <- base_data@Tmax

    # Number of patients with unfinished DLT window (initially none).
    prev_size <- 0

    # Iterate cohorts until stopping.
    while (!should_stop) {
      cohort_size <- size(object@cohort_size, dose = dose, data = base_data)
      safety_window <- windowLength(object@safetyWindow, cohort_size)

      # When cohort patients start relative to trial clock.

      cohort_t0 <- trial_time + cumsum(safety_window$patientGap)

      # Append placeholders for the incoming cohort (no DLTs yet, censored at t_max).
      observed_dlts <- c(observed_dlts, rep(0, cohort_size))
      observed_surv <- c(observed_surv, rep(t_max, cohort_size))
      observed_t0 <- c(observed_t0, cohort_t0)

      # Advance time until next cohort may open (all follow-up constraints satisfied).
      trial_time <- trial_time +
        next_open(window = safety_window, this_surv = rep(t_max, cohort_size))

      # Count patients still within DLT window (for nFollow loop).
      n_follow <- cohort_size + prev_size

      # Identify censored patients indices.
      npt <- length(base_data@x)
      censored_indices <- c(
        which((trial_time - base_data@t0) < base_data@Tmax & base_data@y == 0),
        (npt + 1):(npt + cohort_size)
      )

      # For all possible number of DLTs (0..n_follow):
      for (num_dlts in 0:n_follow) {
        if (num_dlts == 0) {
          # Update base_data for zero DLTs scenario.
          base_data <- update(
            object = base_data,
            y = observed_dlts,
            u = observed_surv,
            t0 = observed_t0,
            x = dose,
            trialtime = trial_time
          )

          dose_limit <- maxDose(object@increments, data = base_data)
          samples <- mcmc(
            data = base_data,
            model = object@model,
            options = mcmcOptions
          )
          next_dose <- nextBest(
            object@nextBest,
            doselimit = dose_limit,
            samples = samples,
            model = object@model,
            data = base_data
          )$value

          increment <- round((next_dose - dose) / dose * 100)
          stop_this_trial <- stopTrial(
            object@stopping,
            dose = next_dose,
            samples = samples,
            model = object@model,
            data = base_data
          )

          ret <- rbind(
            ret,
            list(
              DLTsearly_1 = 0,
              dose = dose,
              DLTs = num_dlts,
              nextDose = next_dose,
              stop = stop_this_trial,
              increment = as.integer(increment)
            )
          )
        } else {
          # Consider two extremes: DLTs at longest vs shortest follow-ups.
          for (dlt_early in 1:num_dlts) {
            curr_dlts <- observed_dlts
            curr_surv <- observed_surv

            if (dlt_early == 1) {
              # Longest follow-up patients have DLTs.
              curr_dlts[censored_indices][1:num_dlts] <- 1
              curr_surv[censored_indices][1:num_dlts] <- apply(
                rbind(
                  rep(t_max, num_dlts),
                  trial_time - observed_t0[censored_indices][1:num_dlts]
                ),
                2,
                min
              )

              data_current <- update(
                object = base_data,
                y = curr_dlts,
                u = curr_surv,
                t0 = observed_t0,
                x = dose,
                trialtime = trial_time
              )
            } else {
              # Shortest follow-up patients have DLTs.
              curr_dlts[rev(censored_indices)][1:num_dlts] <- 1
              curr_surv[rev(censored_indices)][1:num_dlts] <- apply(
                rbind(
                  rep(1, num_dlts),
                  prev_time + 1 - observed_t0[rev(censored_indices)][1:num_dlts]
                ),
                2,
                max
              )

              temp_time <- if (num_dlts >= cohort_size) {
                1 + max(cohort_t0)
              } else {
                trial_time
              }

              data_current <- update(
                object = base_data,
                y = curr_dlts,
                u = curr_surv,
                t0 = observed_t0,
                x = dose,
                trialtime = temp_time
              )
            }

            dose_limit <- maxDose(object@increments, data = data_current)
            samples <- mcmc(
              data = data_current,
              model = object@model,
              options = mcmcOptions
            )
            next_dose <- nextBest(
              object@nextBest,
              doselimit = dose_limit,
              samples = samples,
              model = object@model,
              data = data_current
            )$value

            increment <- round((next_dose - dose) / dose * 100)
            stop_this_trial <- stopTrial(
              object@stopping,
              dose = next_dose,
              samples = samples,
              model = object@model,
              data = data_current
            )

            ret <- rbind(
              ret,
              list(
                DLTsearly_1 = dlt_early,
                dose = dose,
                DLTs = num_dlts,
                nextDose = next_dose,
                stop = stop_this_trial,
                increment = as.integer(increment)
              )
            )
          }
        }
      }

      # Update previous time and compute next state.
      prev_time <- trial_time

      # Filter results at this dose with 0 DLTs and derive new dose.
      results_no_dlts <- subset(ret, dose == dose & DLTs == 0)
      new_dose <- as.numeric(results_no_dlts$nextDose)
      dose_diff <- new_dose - dose
      stop_already <- any(results_no_dlts$stop)

      # Update dose to the maximum recommended among ties.
      dose <- max(new_dose)

      # Patients still within DLT window.
      prev_size <- sum(base_data@u[base_data@y == 0] < base_data@Tmax)

      # No-increment counter and stopping due to no increment.
      no_increment_counter <- if (all(dose_diff == 0)) {
        no_increment_counter + 1L
      } else {
        0L
      }
      stop_no_increment <- (no_increment_counter >= maxNoIncrement)
      if (stop_no_increment) {
        warning(paste(
          "Stopping because",
          no_increment_counter,
          "times no increment vs. previous dose"
        ))
      }

      # Overall stop condition.
      should_stop <- (dose >= max(object@data@doseGrid)) ||
        stop_already ||
        stop_no_increment
    }

    ret
  }
)

# 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
    }
  }
)

# 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
#'   \insertRef{YeungWhiteheadReignerBeyerDiackJaki2015}{crmPack}
#'
#' @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"
    )
}

#' @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 The model used in the [`DualEndpoint`] classes is an extension of this model:
#'   `DualEndpoint` supports both `ProbitNormal` (which is not implemented yet) and
#'   `ProbitLogNormal` models through its `use_log_dose` slot.
#'   `ProbitLogNormal` has no such flag, so always uses `log(x/x*)`as a covariate in
#'   its model. Therefore 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, when `use_log_dose = TRUE` is used.
#'
#' @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 \insertCite{KadaneDickeyWinklerSmithPeters1980;textual}{crmPack}.
#'
#' @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
#' @references
#'   \insertAllCited{}
#'
.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 \insertCite{KadaneDickeyWinklerSmithPeters1980;textual}{crmPack},
#' 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
#' @references
#'   \insertAllCited{}
#'
.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 \insertCite{WhiteheadWilliamson1998;textual}{crmPack}.
#'
#' @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
#' @references
#'   \insertAllCited{}
#'
.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
#'   \insertCite{YeungWhiteheadReignerBeyerDiackJaki2015;textual}{crmPack}.
#'
#' @aliases Effloglog
#' @export
#' @references
#'   \insertAllCited{}
#'
.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 be applied
#'   \insertCite{YeungWhiteheadReignerBeyerDiackJaki2015}{crmPack}.
#'
#' @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.
      # nolint start
      L_obs[i] <- exp(sum(mu[i, ])) *
        pow(p[i] / A, y[i]) *
        pow(1 - p[i], 1 - y[i]) # Not censored.
      # nolint end
      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; see \insertCite{LiuYinYuan2013;textual}{crmPack}.
#'
#' @details Basically, the adaptive function allocates more weight to each record
#'   than the linear function when DLTs are observed early and less weight when DLTs
#'   are observed late. When DLT times are evenly distributed both weights are similar.
#'   In addition, with more DLTs, the adaptive weights become more extreme
#'   and different from the linear weights.
#'
#' @seealso [`DALogisticLogNormal`].
#'
#' @aliases TITELogisticLogNormal
#' @references
#'   \insertAllCited{}
#' @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 see the slot description.
#' @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
#' \insertCite{OQuigleyPepeFisher1990}{crmPack}.
#'
#' @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
#' @references
#'   \insertAllCited{}
#'
.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 \insertCite{YinZhengXu2013;textual}{crmPack}.
#'
#' @seealso [`TITELogisticLogNormal`].
#'
#' @aliases FractionalCRM
#' @export
#' @references
#'   \insertAllCited{}
#'
.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)
      )
      if (!from_prior) {
        ms$tox <- array(dim = c(length(y), length(mean) - 1))
        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", "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
  )
}

# 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 [`NextBestEWOC`] object
#'   contains valid `target`, `overdose` and `max_overdose_prob` parameters.
v_next_best_ewoc <- 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@target, upper = object@overdose[1]),
    "target must be below the overdose interval"
  )
  v$check(
    test_probability_range(object@overdose, bounds_closed = TRUE),
    "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 [`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$check(
    test_flag(object@include_backfill),
    "include_backfill must be a flag"
  )
  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 [`CohortSizeRandom`] object
#'   contains valid `min_size` and `max_size` slots.
v_cohort_size_random <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@min_size, lower = 1),
    "min_size needs to be a positive integer"
  )
  v$check(
    test_int(object@max_size, lower = object@min_size + 1),
    "max_size needs to be an integer larger than min_size"
  )
  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 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
    structure(
      ret,
      nChains = 1L,
      nParameters = nPars,
      nIterations = x@options@iterations,
      nBurnin = x@options@burnin,
      nThin = x@options@step,
      description = elements,
      parallel = FALSE
    )
  }
)


## --------------------------------------------------
## 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
    data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
  }
)

## --------------------------------------------------
## 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
    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()
    }
    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 +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )
  }
)


## --------------------------------------------------
## 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
    gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
  }
)


## -------------------------------------------------------------------------------------
## 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
    data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
  }
)

## -------------------------------------------------------------------------------------
## 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
    data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
  }
)
## ==========================================================================================
## --------------------------------------------------------------------
## 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
    data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
  }
)

#' @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...
    data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
  }
)
## ==============================================================
## ----------------------------------------------------------------
## 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
    data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
  }
)
## ---------------------------------------------------------------------------------
## 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 +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )
  }
)


# --------------------------------------------------------------------------------------------
## 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 +
      scale_linetype_manual(
        breaks = c(
          "Estimate",
          "95% Credible Interval"
        ),
        values = c(1, 2),
        guide = ifelse(showLegend, "legend", "none")
      )
  }
)

## ----------------------------------------------------------------------------------------
## 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"
        )
      )
    )

    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")
      )
  }
)


## ---------------------------------------------------------------------------------------------
## 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 +
      geom_line(linewidth = 1.5, colour = "blue")
  }
)

## ----------------------------------------------------------------------------------------------------------
## 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")
      )
    )

    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)))
  }
)

## ----------------------------------------------------------------------------------------------------
## 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 +
      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))
      )
  }
)
## ==========================================================================================

## -------------------------------------------------------------------------------
## 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
    gridExtra::arrangeGrob(ret1, plot2, ncol = 2)
  }
)

## ------------------------------------------------------------------------------
## 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("Estimated 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
    gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
  }
)
## =======================================================================================================

## ----------------------------------------------------------------
## 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))
    }
    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])
  }

  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) {
        DLTLikelihood(x, data@Tmax)
      }))
    } 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
    data.frame(
      time = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )
  }
)

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

## --------------------------------------------------
## 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)
      )

    gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
  }
)


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

# 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 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"
)

## NextBestEWOC ----

#' @describeIn nextBest find the next best dose based on the EWOC rule.
#'
#' @aliases nextBest-NextBestEWOC
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestEWOC.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestEWOC",
    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)
    ))

    # 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)) {
      # Take the highest eligible dose.
      next_best_level <- sum(is_dose_eligible)
      data@doseGrid[is_dose_eligible][next_best_level]
    } else {
      NA_real_
    }

    # Build plot for the overdosing probability.
    p <- 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 [%]")

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


## 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)
    ) +
      geom_density(colour = "grey50") +
      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)
    ) +
      geom_line(colour = "grey50") +
      geom_point(fill = "grey50", colour = "grey50") +
      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
    ) +
      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
    ) +
      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, ...) {
    if (data@nObs == 0L) {
      # In this case we return Inf, because there is no restriction
      # from this stopping rule because we cannot reference any
      # previous dose. In practice this does not matter because
      # there is a starting dose fixed externally anyway.
      return(Inf)
    }
    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)
  }
)

# and-Stopping-Stopping ----

#' Combine Two Stopping Rules with AND
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The method combining two atomic stopping rules.
#'
#' @param e1 (`Stopping`)\cr first stopping rule object.
#' @param e2 (`Stopping`)\cr second stopping rule object.
#'
#' @return The [`StoppingAll`] object.
#'
#' @aliases and-Stopping-Stopping
#' @example examples/Rules-method-and-stopping-stopping.R
#' @export
#'
setMethod(
  f = "&",
  signature = signature(
    e1 = "Stopping",
    e2 = "Stopping"
  ),
  definition = function(e1, e2) {
    StoppingAll(list(e1, e2))
  }
)

# and-StoppingAll-Stopping ----

#' Combine a Stopping List and an Atomic Stopping Rule with AND
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The method combining a stopping list and an atomic stopping rule.
#'
#' @param e1 (`StoppingAll`)\cr stopping list object.
#' @param e2 (`Stopping`)\cr stopping rule object.
#'
#' @return The modified [`StoppingAll`] object.
#'
#' @aliases and-StoppingAll-Stopping
#' @example examples/Rules-method-and-stoppingAll-stopping.R
#' @export
#'
setMethod(
  f = "&",
  signature = signature(
    e1 = "StoppingAll",
    e2 = "Stopping"
  ),
  definition = function(e1, e2) {
    e1@stop_list <- c(
      e1@stop_list,
      e2
    )
    e1
  }
)

# and-Stopping-StoppingAll ----

#' Combine an Atomic Stopping Rule and a Stopping List with AND
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The method combining an atomic stopping rule and a stopping list.
#'
#' @param e1 (`Stopping`)\cr stopping rule object.
#' @param e2 (`StoppingAll`)\cr stopping list object.
#'
#' @return The modified [`StoppingAll`] object.
#'
#' @aliases and-Stopping-StoppingAll
#' @example examples/Rules-method-and-stopping-stoppingAll.R
#' @export
#'
setMethod(
  f = "&",
  signature = signature(
    e1 = "Stopping",
    e2 = "StoppingAll"
  ),
  definition = function(e1, e2) {
    e2@stop_list <- c(
      e1,
      e2@stop_list
    )
    e2
  }
)

# or-Stopping-Stopping ----

#' Combine Two Stopping Rules with OR
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The method combining two atomic stopping rules.
#'
#' @param e1 (`Stopping`)\cr first stopping rule object.
#' @param e2 (`Stopping`)\cr second stopping rule object.
#'
#' @return The [`StoppingAny`] object.
#'
#' @aliases |,Stopping,Stopping-method
#' @name or-Stopping-Stopping
#' @example examples/Rules-method-or-stopping-stopping.R
#' @export
#'
setMethod(
  f = "|",
  signature = signature(
    e1 = "Stopping",
    e2 = "Stopping"
  ),
  definition = function(e1, e2) {
    StoppingAny(list(e1, e2))
  }
)

# or-StoppingAny-Stopping ----

#' Combine a Stopping List and an Atomic Stopping Rule with OR
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The method combining a stopping list and an atomic stopping rule.
#'
#' @param e1 (`StoppingAny`)\cr stopping list object.
#' @param e2 (`Stopping`)\cr stopping rule object.
#'
#' @return The modified [`StoppingAny`] object.
#'
#' @aliases |,StoppingAny,Stopping-method
#' @name or-StoppingAny-Stopping
#' @example examples/Rules-method-or-stoppingAny-stopping.R
#' @export
#'
setMethod(
  f = "|",
  signature = signature(
    e1 = "StoppingAny",
    e2 = "Stopping"
  ),
  definition = function(e1, e2) {
    e1@stop_list <- c(
      e1@stop_list,
      e2
    )
    e1
  }
)

# or-Stopping-StoppingAny ----

#' Combine an Atomic Stopping Rule and a Stopping List with OR
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The method combining an atomic stopping rule and a stopping list.
#'
#' @param e1 (`Stopping`)\cr stopping rule object.
#' @param e2 (`StoppingAny`)\cr stopping list object.
#'
#' @return The modified [`StoppingAny`] object.
#'
#' @aliases |,Stopping,StoppingAny-method
#' @name or-Stopping-StoppingAny
#' @example examples/Rules-method-or-stopping-stoppingAny.R
#' @export
#'
setMethod(
  f = "|",
  signature = signature(
    e1 = "Stopping",
    e2 = "StoppingAny"
  ),
  definition = function(e1, e2) {
    e2@stop_list <- c(
      e1,
      e2@stop_list
    )
    e2
  }
)

# Stopping ----

## stopTrial ----

#' 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"
)

## stopTrial-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)
  }
)

## stopTrial-StoppingList ----

#' @describeIn stopTrial Stop based on multiple stopping rules.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingList
#' @example examples/Rules-method-stopTrial-StoppingList.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingList",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Evaluate the individual stopping rules in the list.
    individual_results <-
      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.
    overall_result <- stopping@summary(as.logical(individual_results))

    # Retrieve individual text messages, but let them in the list structure.
    overall_text <- lapply(individual_results, attr, "message")

    structure(
      overall_result,
      message = overall_text,
      individual = individual_results
    )
  }
)

## stopTrial-StoppingAll ----

#' @describeIn stopTrial Stop based on fulfillment of all multiple stopping
#'   rules.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingAll
#' @example examples/Rules-method-stopTrial-StoppingAll.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingAll",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Evaluate the individual stopping rules in the list.
    individual_results <-
      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.
    overall_result <- all(as.logical(individual_results))

    # Retrieve individual text messages, but let them in the list structure.
    overall_text <- lapply(individual_results, attr, "message")

    structure(
      overall_result,
      message = overall_text,
      individual = individual_results,
      report_label = stopping@report_label
    )
  }
)


## stopTrial-StoppingAny ----

#' @describeIn stopTrial Stop based on fulfillment of any stopping rule.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingAny
#' @example examples/Rules-method-stopTrial-StoppingAny.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingAny",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Evaluate the individual stopping rules in the list.
    individual_results <-
      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.
    overall_result <- any(as.logical(individual_results))

    # Retrieve individual text messages, but let them in the list structure.
    overall_text <- lapply(individual_results, attr, "message")

    structure(
      overall_result,
      message = overall_text,
      individual = individual_results,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingCohortsNearDose ----

#' @describeIn stopTrial Stop based on number of cohorts near to next best
#'   dose.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingCohortsNearDose
#' @example examples/Rules-method-stopTrial-StoppingCohortsNearDose.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingCohortsNearDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = 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?
    index_patients <- which((data@x >= lower) & (data@x <= upper))

    # How many cohorts?
    n_cohorts <- length(unique(data@cohort[index_patients]))

    # So can we stop?
    do_stop <- n_cohorts >= stopping@nCohorts

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

    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingPatientsNearDose ----

#' @describeIn stopTrial Stop based on number of patients near to next best
#'   dose.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingPatientsNearDose
#' @example examples/Rules-method-stopTrial-StoppingPatientsNearDose.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingPatientsNearDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = 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

    # Get patients' dose levels.
    doses <- data@x
    if (!stopping@include_backfill) {
      doses <- doses[!data@backfilled]
    }

    # How many patients lie there?
    n_patients <- ifelse(
      is.na(dose),
      0,
      sum((doses >= lower) & (doses <= upper))
    )

    # So can we stop?
    do_stop <- n_patients >= stopping@nPatients

    # Generate message.
    text <- paste0(
      n_patients,
      ifelse(
        stopping@include_backfill,
        " patients ",
        " patients (excluding backfilled) "
      ),
      "lie within ",
      stopping@percentage,
      "% of the next best dose ",
      dose,
      ". This ",
      ifelse(do_stop, "reached", "is below"),
      " the required ",
      stopping@nPatients,
      " patients"
    )

    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingMinCohorts ----

#' @describeIn stopTrial Stop based on minimum number of cohorts.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingMinCohorts
#' @example examples/Rules-method-stopTrial-StoppingMinCohorts.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMinCohorts",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Determine number of cohorts.
    n_cohorts <- length(unique(data@cohort))

    # So can we stop?
    do_stop <- n_cohorts >= stopping@nCohorts

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

    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingMinPatients ----

#' @describeIn stopTrial Stop based on minimum number of patients.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingMinPatients
#' @example examples/Rules-method-stopTrial-StoppingMinPatients.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMinPatients",
    dose = "ANY",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # So can we stop?
    do_stop <- data@nObs >= stopping@nPatients

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

    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-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
    )
  }
)

## stopTrial-StoppingMTDdistribution ----

#' @describeIn stopTrial Stop based on MTD distribution.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingMTDdistribution
#' @example examples/Rules-method-stopTrial-StoppingMTDdistribution.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMTDdistribution",
    dose = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "ANY"
  ),
  definition = 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.
    mtd_samples <- dose(
      x = stopping@target,
      model,
      samples,
      ...
    )

    # What is the absolute threshold?
    abs_thresh <- stopping@thresh * dose

    # What is the probability to be above this dose?
    prob <- ifelse(
      is.na(abs_thresh),
      0,
      mean(mtd_samples > abs_thresh)
    )

    # So can we stop?
    do_stop <- 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(do_stop, "greater than or equal to", "strictly less than"),
        "the required",
        round(stopping@prob * 100),
        "%"
      )

    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-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
    )
  }
)

## stopTrial-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
    )
  }
)

## stopTrial-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
    )
  }
)

## stopTrial-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
  }
)

## stopTrial-StoppingHighestDose ----

#' @describeIn stopTrial Stop when the highest dose is reached.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingHighestDose
#' @example examples/Rules-method-stopTrial-StoppingHighestDose.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingHighestDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    is_highest_dose <- ifelse(
      is.na(dose),
      FALSE,
      (dose == data@doseGrid[data@nGrid])
    )
    structure(
      is_highest_dose,
      message = paste(
        "Next best dose is",
        dose,
        "and thus",
        ifelse(is_highest_dose, "the", "not the"),
        "highest dose"
      ),
      report_label = stopping@report_label
    )
  }
)

## stopTrial-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),
      ...
    )
  }
)

## stopTrial-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 = "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."
      )
    )
  }
)

## stopTrial-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
    )
  }
)


## stopTrial-StoppingTDCIRatio ----

#' @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 incorporates only DLE responses and DLE samples are given.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingTDCIRatio
#' @example examples/Rules-method-stopTrialCITDsamples.R
#' @export
#'
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)
  }
)

## stopTrial-StoppingTDCIRatio ----

#' @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 incorporates only DLE responses and no DLE samples are involved.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingTDCIRatio
#' @example examples/Rules-method-stopTrialCITD.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingTDCIRatio",
    dose = "ANY",
    samples = "missing",
    model = "ModelTox",
    data = "ANY"
  ),
  definition = 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
    var_eta <- 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(var_eta))
    ratio <- ci[2] / ci[1]

    # So can we stop?
    do_stop <- 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(do_stop, "is less than or equal to", "greater than"),
      "target_ratio =",
      stopping@target_ratio
    )
    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

## stopTrial-StoppingMaxGainCIRatio ----

#' @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 incorporates
#'   DLE and efficacy responses and DLE and efficacy samples are also used.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param TDderive (`function`)\cr the function which derives from the input,
#'   a vector of the posterior samples called `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 (`ModelEff`)\cr the efficacy model.
#' @param Effsamples (`Samples`)\cr the efficacy samples.
#' @param Gstarderive (`function`)\cr the function which derives from the input,
#'   a vector of the posterior Gstar (the dose which gives the maximum gain
#'   value) samples called `Gstarsamples`, the final next best Gstar estimate.
#'
#' @aliases stopTrial-StoppingMaxGainCIRatio
#' @example examples/Rules-method-stopTrialCIMaxGainSamples.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMaxGainCIRatio",
    dose = "ANY",
    samples = "Samples",
    model = "ModelTox",
    data = "DataDual"
  ),
  definition = 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.
    td_target_end_of_trial_samples <- dose(
      x = prob_target,
      model = model,
      samples = samples,
      ...
    )
    # Find the TDtarget End of trial estimate.
    td_target_end_of_trial_estimate <- TDderive(td_target_end_of_trial_samples)

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

    gain_samples <- 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.
      gain_samples[, i] <- gain(
        dose = points[i],
        model,
        samples,
        Effmodel,
        Effsamples,
        ...
      )
    }

    # Find the maximum gain value samples.
    max_gain_samples <- apply(gain_samples, 1, max)

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

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

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

    # Find which is smaller (TDtargetEndOfTrialEstimate or Gstar).
    if (td_target_end_of_trial_estimate <= gstar) {
      # Find the upper and lower limit of the 95% credibility interval and its
      # ratio of the smaller.
      ci <- ci_tdeot
      ratio <- ratio_tdeot
      choose_td <- TRUE
    } else {
      ci <- ci_gstar
      ratio <- ratio_gstar
      choose_td <- FALSE
    }

    # So can we stop?
    do_stop <- ratio <= stopping@target_ratio
    # Generate message.
    text1 <- paste(
      "Gstar estimate is",
      round(gstar, 4),
      "with 95% CI (",
      round(ci_gstar[1], 4),
      ",",
      round(ci_gstar[2], 4),
      ") and its ratio =",
      round(ratio_gstar, 4)
    )
    text2 <- paste(
      "TDtargetEndOfTrial estimate is ",
      round(td_target_end_of_trial_estimate, 4),
      "with 95% CI (",
      round(ci_tdeot[1], 4),
      ",",
      round(ci_tdeot[2], 4),
      ") and its ratio=",
      round(ratio_tdeot, 4)
    )
    text3 <- paste(
      ifelse(choose_td, "TDtargetEndOfTrial estimate", "Gstar estimate"),
      "is smaller with ratio =",
      round(ratio, 4),
      " which is ",
      ifelse(do_stop, "is less than or equal to", "greater than"),
      "target_ratio =",
      stopping@target_ratio
    )
    text <- c(text1, text2, text3)
    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

#' @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 incorporates
#'   DLE and efficacy responses without DLE and efficacy samples involved.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @aliases stopTrial-StoppingMaxGainCIRatio
#' @example examples/Rules-method-stopTrialCIMaxGain.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMaxGainCIRatio",
    dose = "ANY",
    samples = "missing",
    model = "ModelTox",
    data = "DataDual"
  ),
  definition = 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.
    td_target_end_of_trial <- dose(
      x = prob_target,
      model = model,
      ...
    )

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

    lowest_dose <- min(data@doseGrid)

    gstar <- (optim(
      lowest_dose,
      gainfun,
      method = "L-BFGS-B",
      lower = lowest_dose,
      upper = max(data@doseGrid)
    )$par)
    max_gain <- -(optim(
      lowest_dose,
      gainfun,
      method = "L-BFGS-B",
      lower = lowest_dose,
      upper = max(data@doseGrid)
    )$value)
    if (data@placebo) {
      log_gstar <- log(gstar + Effmodel@const)
    } else {
      log_gstar <- log(gstar)
    }

    # From paper (Yeung et. al 2015).
    mean_eff_gstar <- Effmodel@theta1 + Effmodel@theta2 * log(log_gstar)

    denom <- (model@phi2) * (mean_eff_gstar) * (1 + log_gstar * model@phi2)

    dgphi1 <- -(mean_eff_gstar * log_gstar * model@phi2 - Effmodel@theta2) /
      denom

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

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

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

    delta_g <- 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 are independent of theta1 and
    # theta2.
    empty_matrix <- matrix(0, 2, 2)
    cov_beta <- cbind(
      rbind(model@Pcov, empty_matrix),
      rbind(empty_matrix, Effmodel@Pcov)
    )
    var_log_gstar <- as.vector(t(delta_g) %*% cov_beta %*% delta_g)

    # Find the upper and lower limit of the 95% credibility interval of Gstar.
    ci_gstar <- exp(log_gstar + c(-1, 1) * 1.96 * sqrt(var_log_gstar))

    # The ratio of the upper to the lower 95% credibility interval.
    ratio_gstar <- ci_gstar[2] / ci_gstar[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

    var_eta <- as.vector(m1 %*% m2 %*% t(m1))

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

    # The ratio of the upper to the lower 95% credibility interval.
    ratio_tdeot <- ci_tdeot[2] / ci_tdeot[1]

    if (gstar <= td_target_end_of_trial) {
      choose_td <- FALSE
      ci <- c()
      ci[2] <- ci_gstar[2]
      ci[1] <- ci_gstar[1]
      ratio <- ratio_gstar
    } else {
      choose_td <- TRUE
      ci <- c()
      ci[2] <- ci_tdeot[2]
      ci[1] <- ci_tdeot[1]
      ratio <- ratio_tdeot
    }
    # So can we stop?
    do_stop <- ratio <= stopping@target_ratio
    # Generate message.
    text1 <- paste(
      "Gstar estimate is",
      round(gstar, 4),
      "with 95% CI (",
      round(ci_gstar[1], 4),
      ",",
      round(ci_gstar[2], 4),
      ") and its ratio =",
      round(ratio_gstar, 4)
    )
    text2 <- paste(
      "TDtargetEndOfTrial estimate is ",
      round(td_target_end_of_trial, 4),
      "with 95% CI (",
      round(ci_tdeot[1], 4),
      ",",
      round(ci_tdeot[2], 4),
      ") and its ratio=",
      round(ratio_tdeot, 4)
    )
    text3 <- paste(
      ifelse(choose_td, "TDtargetEndOfTrial estimate", "Gstar estimate"),
      "is smaller with ratio =",
      round(ratio, 4),
      "which is ",
      ifelse(do_stop, "is less than or equal to", "greater than"),
      "target_ratio =",
      stopping@target_ratio
    )
    text <- c(text1, text2, text3)
    # Return both.
    structure(
      do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

# maxSize ----

## generic ----

#' "MAX" Combination of Cohort Size Rules
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function combines cohort size rules by taking the maximum of all sizes.
#'
#' @param ... Objects of class [`CohortSize`].
#'
#' @return The combination as an object of class [`CohortSizeMax`].
#'
#' @seealso [minSize()]
#' @export
#'
setGeneric(
  name = "maxSize",
  def = function(...) {
    # There should be no default method, therefore just forward to next method.
    standardGeneric("maxSize")
  },
  valueClass = "CohortSizeMax"
)

## maxSize-CohortSize ----

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

# minSize ----

## generic ----

#' "MIN" Combination of Cohort Size Rules
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function combines cohort size rules by taking the minimum of all sizes.
#'
#' @param ... Objects of class [`CohortSize`].
#'
#' @return The combination as an object of class [`CohortSizeMin`].
#'
#' @seealso [maxSize()]
#' @export
#'
setGeneric(
  name = "minSize",
  def = function(...) {
    # There should be no default method, therefore just forward to next method.
    standardGeneric("minSize")
  },
  valueClass = "CohortSizeMin"
)

## minSize-CohortSize ----

#' @describeIn minSize The method combining cohort size rules by taking minimum.
#'
#' @aliases minSize-CohortSize
#' @example examples/Rules-method-minSize.R
#' @export
#'
setMethod(
  f = "minSize",
  signature = "CohortSize",
  definition = 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]
  }
)

## size-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]
  }
)

## size-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_multi_class(data, c("Data", "DataOrdinal"))

    # 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)
  }
)

## size-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_multi_class(data, c("Data", "DataOrdinal"))

    # 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)
  }
)

## size-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
    }
  }
)

## size-CohortSizeRandom ----

#' @describeIn size Random cohort size drawn uniformly between min and max size.
#'
#' @param dose the next dose.
#' @param ... not used.
#'
#' @aliases size-CohortSizeRandom
#' @example examples/Rules-method-size-CohortSizeRandom.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeRandom"
  ),
  definition = function(object, dose, ...) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      0L
    } else {
      as.integer(sample(
        seq(object@min_size, object@max_size),
        size = 1
      ))
    }
  }
)

## 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)) {
      0L
    } else {
      assert_class(data, "DataParts")
      object@cohort_sizes[data@nextPart]
    }
  }
)

## size-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),
      ...
    )
  }
)

# windowLength ----

## generic ----

#' Determine the Safety Window Length of the Next Cohort
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function determines the safety window length of the next cohort.
#'
#' @param safetyWindow (`SafetyWindow`)\cr the rule, an object of class
#'   [`SafetyWindow`].
#' @param size (`integer`)\cr the next cohort size.
#' @param data (`DataDA`)\cr the data input, an object of class [`DataDA`].
#' @param ... additional arguments without method dispatch.
#'
#' @return The `windowLength` as a list of safety window parameters
#'   (`gap`, `follow`, `follow_min`).
#'
#' @export
#'
setGeneric(
  name = "windowLength",
  def = function(safetyWindow, size, ...) {
    # There should be no default method, therefore just forward to next method.
    standardGeneric("windowLength")
  },
  valueClass = "list"
)

## windowLength-SafetyWindowSize ----

#' @describeIn windowLength Determine safety window length based on the cohort
#'   size.
#'
#' @aliases windowLength-SafetyWindowSize
#' @example examples/Rules-method-windowLength-SafetyWindowSize.R
#' @export
#'
setMethod(
  f = "windowLength",
  signature = signature(
    safetyWindow = "SafetyWindowSize",
    size = "ANY"
  ),
  definition = 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.
    patient_gap <- head(
      c(
        0,
        safetyWindow@gap[[interval]],
        rep(tail(safetyWindow@gap[[interval]], 1), 100)
      ),
      size
    )
    patient_follow <- safetyWindow@follow
    patient_follow_min <- safetyWindow@follow_min

    ret <- list(
      patientGap = patient_gap,
      patientFollow = patient_follow,
      patientFollowMin = patient_follow_min
    )

    ret
  }
)

## windowLength-SafetyWindowConst ----

#' @describeIn windowLength Constant safety window length.
#'
#' @aliases windowLength-SafetyWindowConst
#' @example examples/Rules-method-windowLength-SafetyWindowConst.R
#' @export
#'
setMethod(
  f = "windowLength",
  signature = signature(
    safetyWindow = "SafetyWindowConst",
    size = "ANY"
  ),
  definition = function(safetyWindow, size, ...) {
    # First element should be 0.
    patient_gap <- head(
      c(
        0,
        safetyWindow@gap,
        rep(tail(safetyWindow@gap, 1), 100)
      ),
      size
    )
    patient_follow <- safetyWindow@follow
    patient_follow_min <- safetyWindow@follow_min

    ret <- list(
      patientGap = patient_gap,
      patientFollow = patient_follow,
      patientFollowMin = patient_follow_min
    )

    ret
  }
)

# 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)
  }
)

#' @include Simulations-class.R
#' @include helpers.R
NULL

# h_plot_simulation_trajectory ----

#' Helper Function to Create Trajectory Plot
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Creates a trajectory plot showing dose level statistics across patients.
#'
#' @param sim_doses (`list`)\cr list of simulated doses per trial.
#' @param max_patients (`integer`)\cr maximum number of patients.
#' @param has_placebo (`flag`)\cr whether the design includes placebo.
#'
#' @return A `ggplot` object.
#'
#' @keywords internal
h_plot_simulation_trajectory <- function(sim_doses, max_patients, has_placebo) {
  # Create matrix of simulated dose trajectories.
  sim_doses_mat <- matrix(
    data = NA,
    nrow = length(sim_doses),
    ncol = max_patients
  )

  for (i in seq_along(sim_doses)) {
    sim_doses_mat[i, seq_along(sim_doses[[i]])] <- sim_doses[[i]]
  }

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

  # Create plot title.
  my_title <- if (has_placebo) {
    "Patient (placebo were excluded)"
  } else {
    "Patient"
  }

  # Create and return plot.
  ggplot() +
    geom_step(
      aes(
        x = patient,
        y = traj,
        group = Statistic,
        linetype = Statistic
      ),
      linewidth = 1.2,
      colour = "blue",
      data = traj_df
    ) +
    xlab(my_title) +
    ylab("Dose Level")
}

# h_plot_doses_tried ----

#' Helper Function to Create Doses Tried Plot
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Creates a bar plot showing average proportions of doses tested.
#'
#' @param sim_doses (`list`)\cr list of simulated doses per trial.
#' @param dose_grid (`numeric`)\cr dose grid.
#'
#' @return A `ggplot` object.
#'
#' @keywords internal
h_plot_doses_tried <- function(sim_doses, dose_grid) {
  # Get the dose distributions by trial.
  dose_distributions <- sapply(
    sim_doses,
    function(s) {
      if (length(s) > 0) {
        prop.table(table(factor(s, levels = dose_grid)))
      } else {
        rep(0, length(dose_grid))
      }
    }
  )

  # Derive the average dose distribution across trial simulations.
  average_dose_dist <- rowMeans(dose_distributions)

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

  # Create and return plot.
  ggplot() +
    geom_bar(
      data = dat,
      aes(x = dose, y = perc),
      stat = "identity",
      position = "identity",
      width = min(diff(dose_grid)) / 2
    ) +
    xlab("Dose level") +
    ylab("Average proportion [%]")
}

# plot-GeneralSimulations ----

#' Plot `GeneralSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize the simulations with plots.
#'
#' This plot method can be applied to [`GeneralSimulations`] objects in order
#' to summarize them graphically. Possible `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 `type` argument.
#'
#' @param x (`GeneralSimulations`)\cr the object we want to plot from.
#' @param y (`missing`)\cr not used.
#' @param type (`character`)\cr the type of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot` object if a single plot is
#'   asked for, otherwise a `gtable` object.
#'
#' @aliases plot-GeneralSimulations-missing
#' @example examples/Simulations-method-plotSIMsingle.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "GeneralSimulations",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c("trajectory", "dosesTried"),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Start the plot list.
    plot_list <- list()
    plot_index <- 0L

    # Summary of the trajectories.
    if ("trajectory" %in% type) {
      # If design with placebo, then exclude placebo patients.
      if (x@data[[1]]@placebo) {
        pl <- x@data[[1]]@doseGrid[1]
        sim_doses <- lapply(
          x@data,
          function(y) {
            y@x[y@x != pl]
          }
        )
      } else {
        sim_doses <- lapply(
          x@data,
          slot,
          "x"
        )
      }

      max_patients <- max(sapply(sim_doses, length))

      # Create trajectory plot.
      plot_list[[plot_index <- plot_index + 1L]] <-
        h_plot_simulation_trajectory(
          sim_doses = sim_doses,
          max_patients = max_patients,
          has_placebo = x@data[[1]]@placebo
        )
    }

    # Average distribution of the doses tried.
    if ("dosesTried" %in% type) {
      # Get the doses tried.
      sim_doses <- lapply(
        x@data,
        slot,
        "x"
      )

      # Create doses tried plot.
      plot_list[[plot_index <- plot_index + 1L]] <-
        h_plot_doses_tried(
          sim_doses = sim_doses,
          dose_grid = x@data[[1]]@doseGrid
        )
    }

    # Return plot(s).
    if (identical(length(plot_list), 1L)) {
      # Just return single plot.
      plot_list[[1L]]
    } else {
      # Otherwise arrange them.
      do.call(gridExtra::arrangeGrob, plot_list)
    }
  }
)

# plot-DualSimulations ----

#' Plot `DualSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This plot method can be applied to [`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 (`DualSimulations`)\cr the object we want to plot from.
#' @param y (`missing`)\cr not used.
#' @param type (`character`)\cr the type of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot` object if a single plot is asked for,
#'   otherwise a `gtable` object.
#'
#' @aliases plot-DualSimulations-missing
#' @example examples/Simulations-method-plot-DualSimulations.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "DualSimulations",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c("trajectory", "dosesTried", "sigma2W", "rho"),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Start the plot list.
    plot_list <- list()
    plot_index <- 0L

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

    # Are there more plots from general?
    more_from_general <- (length(type_reduced) > 0)

    # If so, then produce these plots.
    if (more_from_general) {
      gen_plot <- callNextMethod(x = x, y = y, type = type_reduced)
    }

    # Now to the specific dual-endpoint plots.

    # Biomarker variance estimates boxplot.
    if ("sigma2W" %in% type) {
      plot_list[[plot_index <- plot_index + 1L]] <-
        ggplot(
          data = data.frame(y = x@sigma2w_est),
          aes(x = factor(0), y = y)
        ) +
        geom_boxplot() +
        coord_flip() +
        scale_x_discrete(breaks = NULL) +
        xlab("") +
        ylab("Biomarker variance estimates")
    }

    # Correlation estimates boxplot.
    if ("rho" %in% type) {
      plot_list[[plot_index <- plot_index + 1L]] <-
        ggplot(
          data = data.frame(y = x@rho_est),
          aes(x = factor(0), y = y)
        ) +
        geom_boxplot() +
        coord_flip() +
        scale_x_discrete(breaks = NULL) +
        xlab("") +
        ylab("Correlation estimates")
    }

    # Return plot(s).
    if (identical(length(plot_list), 0L)) {
      gen_plot
    } else if (identical(length(plot_list), 1L)) {
      if (more_from_general) {
        gridExtra::arrangeGrob(gen_plot, plot_list[[1L]])
      } else {
        plot_list[[1L]]
      }
    } else {
      ret <- do.call(gridExtra::arrangeGrob, plot_list)
      if (more_from_general) {
        gridExtra::arrangeGrob(gen_plot, ret)
      } else {
        ret
      }
    }
  }
)

# summary-GeneralSimulations ----

#' Summarize the `GeneralSimulations`, Relative to a Given Truth
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize simulations relative to a given true dose-toxicity curve.
#'
#' @param object (`GeneralSimulations`)\cr the object we want to summarize.
#' @param truth (`function`)\cr a function which takes as input a dose (vector)
#'   and returns the true probability (vector) for toxicity.
#' @param target (`numeric`)\cr the target toxicity interval (default: 20-35%)
#'   used for the computations.
#' @param ... additional arguments can be supplied here for `truth`.
#'
#' @return An object of class [`GeneralSimulationsSummary`].
#'
#' @aliases summary-GeneralSimulations
#' @export
#'
setMethod(
  f = "summary",
  signature = signature(object = "GeneralSimulations"),
  def = function(object, truth, target = c(0.2, 0.35), ...) {
    # Validate arguments.
    assert_function(truth)
    assert_numeric(target, min.len = 1, max.len = 2, lower = 0, upper = 1)
    if (length(target) == 2) {
      assert_true(target[1] < target[2])
    }

    # Extract dose grid.
    dose_grid <- object@data[[1]]@doseGrid

    # Evaluate true toxicity at dose grid.
    true_tox <- truth(dose_grid, ...)

    # Find dose interval corresponding to target tox interval.
    target_dose_interval <- 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(dose_grid)
          )$root,
          silent = TRUE
        )
        if (inherits(r, "try-error")) {
          NA_real_
        } else {
          r
        }
      }
    )

    # What are the levels above target interval?
    x_above_target <- which(true_tox > target[2])

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

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

    # Doses selected for MTD.
    dose_selected <- object@doses

    # Replace NA by 0.
    dose_selected[is.na(dose_selected)] <- 0

    # Dose most often selected as MTD.
    dose_most_selected <- as.numeric(names(which.max(table(dose_selected))))
    x_most_selected <- match_within_tolerance(
      dose_most_selected,
      table = dose_grid
    )

    # 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) {
        which_at_this_dose <- which(d@x == dose_most_selected)
        n_at_this_dose <- length(which_at_this_dose)
        n_dlt_at_this_dose <- sum(d@y[which_at_this_dose])
        c(
          nAtThisDose = n_at_this_dose,
          nDLTatThisDose = n_dlt_at_this_dose
        )
      }
    )

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

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

    # Number of patients treated above target tox interval.
    n_above_target <- sapply(
      object@data,
      function(d) {
        sum(d@xLevel %in% x_above_target)
      }
    )

    # Proportion of trials selecting target MTD.
    tox_at_doses <- truth(dose_selected, ...)
    prop_at_target <- mean(
      (tox_at_doses > target[1]) & (tox_at_doses < target[2])
    )

    # Any backfilled? First check if the slot is available.
    any_backfilled <- methods::.hasSlot(object@data[[1]], "backfilled")

    # Number of backfill patients.
    n_backfill <- if (any_backfilled) {
      sapply(
        object@data,
        function(d) {
          sum(d@backfilled)
        }
      )
    } else {
      NULL
    }
    if (!is.null(n_backfill)) {
      any_backfilled <- any(n_backfill > 0)
    }

    # Doses for backfill patients.
    backfill_doses <- if (any_backfilled) {
      lapply(
        object@data,
        function(d) {
          d@x[d@backfilled]
        }
      )
    } else {
      list()
    }

    # Give back an object of class GeneralSimulationsSummary.
    .GeneralSimulationsSummary(
      target = target,
      target_dose_interval = target_dose_interval,
      nsim = length(object@data),
      prop_dlts = prop_dlts,
      mean_tox_risk = mean_tox_risk,
      dose_selected = dose_selected,
      dose_most_selected = dose_most_selected,
      obs_tox_rate_at_dose_most_selected = obs_tox_rate_at_dose_most_selected,
      n_obs = n_obs,
      n_above_target = n_above_target,
      tox_at_doses_selected = tox_at_doses,
      prop_at_target = prop_at_target,
      dose_grid = dose_grid,
      placebo = object@data[[1]]@placebo,
      any_backfilled = any_backfilled,
      n_backfill = if (any_backfilled) n_backfill else NULL,
      backfill_doses = backfill_doses
    )
  }
)

# summary-Simulations ----

#' Summarize Model-Based Design Simulations
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize the model-based design simulations, relative to a given truth.
#'
#' @param object (`Simulations`)\cr the object we want to summarize.
#' @param truth (`function`)\cr a function which takes as input a dose (vector)
#'   and returns the true probability (vector) for toxicity.
#' @param target (`numeric`)\cr the target toxicity interval (default: 20-35%)
#'   used for the computations.
#' @param ... additional arguments can be supplied here for `truth`.
#'
#' @return An object of class [`SimulationsSummary`].
#'
#' @aliases summary-Simulations
#' @example examples/Simulations-method-summary.R
#' @export
#'
setMethod(
  f = "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,
      ...
    )

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

    # Dose level most often selected as MTD.
    x_most_selected <-
      match_within_tolerance(start@dose_most_selected, table = dose_grid)

    # Fitted toxicity rate at dose most often selected.
    fit_at_dose_most_selected <-
      sapply(
        object@fit,
        function(f) {
          f$middle[x_most_selected]
        }
      )

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

    # Give back an object of class SimulationsSummary.
    .SimulationsSummary(
      start,
      stop_report = object@stop_report,
      additional_stats = object@additional_stats,
      fit_at_dose_most_selected = fit_at_dose_most_selected,
      mean_fit = mean_fit
    )
  }
)

# summary-DualSimulations ----

#' Summarize Dual-Endpoint Design Simulations
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize the dual-endpoint design simulations, relative to given true
#' dose-toxicity and dose-biomarker curves.
#'
#' @param object (`DualSimulations`)\cr the object we want to summarize.
#' @param trueTox (`function`)\cr a function which takes as input a dose
#'   (vector) and returns the true probability (vector) for toxicity.
#' @param trueBiomarker (`function`)\cr a function which takes as input a dose
#'   (vector) and returns the true biomarker level (vector).
#' @param target (`numeric`)\cr the target toxicity interval (default: 20-35%)
#'   used for the computations.
#' @param ... additional arguments can be supplied here for `trueTox` and
#'   `trueBiomarker`.
#'
#' @return An object of class [`DualSimulationsSummary`].
#'
#' @aliases summary-DualSimulations
#' @example examples/Simulations-method-summary-DualSimulations.R
#' @export
#'
setMethod(
  f = "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,
      ...
    )

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

    # Dose level most often selected as MTD.
    x_most_selected <-
      match_within_tolerance(start@dose_most_selected, table = dose_grid)

    # Fitted biomarker level at dose most often selected.
    biomarker_fit_at_dose_most_selected <-
      sapply(
        object@fit_biomarker,
        function(f) {
          f$middleBiomarker[x_most_selected]
        }
      )

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

    # Give back an object of class DualSimulationsSummary.
    .DualSimulationsSummary(
      start,
      biomarker_fit_at_dose_most_selected = biomarker_fit_at_dose_most_selected,
      mean_biomarker_fit = mean_biomarker_fit
    )
  }
)

# Report-class ----

#' @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)
        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 ----

#' Show `Simulations` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Display a brief representation of the [GeneralSimulations] object.
#'
#' @param object (`GeneralSimulations`)\cr the object we want to print.
#'
#' @return Invisibly returns the object itself.
#'
#' @aliases show-GeneralSimulations
#' @export
setMethod(
  f = "show",
  signature = signature(object = "GeneralSimulations"),
  def = function(object) {
    cat(paste0(
      "An object of class '",
      class(object),
      "' containing ",
      length(object@data),
      " simulated trials.\n",
      "Please use 'summary()' to obtain more information.\n"
    ))
    invisible(object)
  }
)

# show-GeneralSimulationsSummary ----

#' Show the Summary of the Simulations
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Display a summary of general simulation results.
#'
#' @param object (`GeneralSimulationsSummary`)\cr the object we want to print.
#'
#' @return Invisibly returns a data frame of the results with one row and
#'   appropriate column names.
#'
#' @aliases show-GeneralSimulationsSummary
#' @export
#'
setMethod(
  f = "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"
    )

    # Backfill information.
    if (object@any_backfilled) {
      r$report(
        "n_backfill",
        "Number of backfill patients",
        percent = FALSE
      )
      back_dose_tab <- prop.table(table(
        unlist(object@backfill_doses)
      ))
      back_doses <- names(back_dose_tab)
      back_dose_percent <- paste0(round(back_dose_tab * 100, 1), "%")
      cat(
        "Doses for backfill patients:",
        toString(paste0(back_doses, ": ", back_dose_percent)),
        "\n"
      )
    }

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

# show-SimulationsSummary ----

#' Show the Summary of Model-Based Design Simulations
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Display a summary of model-based design simulation results.
#'
#' @param object (`SimulationsSummary`)\cr the object we want to print.
#'
#' @return Invisibly returns a data frame of the results with one row and
#'   appropriate column names.
#'
#' @aliases show-SimulationsSummary
#' @example examples/Simulations-method-show-SimulationsSummary.R
#' @export
#'
setMethod(
  f = "show",
  signature = signature(object = "SimulationsSummary"),
  def = function(object) {
    # Call the parent method.
    df <- callNextMethod(object)
    df_names <- names(df)

    # Start report object.
    r <- Report$new(
      object = object,
      df = df,
      dfNames = df_names
    )

    # 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-DualSimulationsSummary ----

#' Show the Summary of Dual-Endpoint Simulations
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Display a summary of dual-endpoint simulation results.
#'
#' @param object (`DualSimulationsSummary`)\cr the object we want to print.
#'
#' @return Invisibly returns a data frame of the results with one row and
#'   appropriate column names.
#'
#' @aliases show-DualSimulationsSummary
#' @example examples/Simulations-method-show-DualSimulationsSummary.R
#' @export
#'
setMethod(
  f = "show",
  signature = signature(object = "DualSimulationsSummary"),
  def = function(object) {
    # Call the parent method.
    df <- callNextMethod(object)
    df_names <- names(df)

    # Start report object.
    r <- Report$new(
      object = object,
      df = df,
      dfNames = df_names
    )

    # 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)
  }
)

# plot-GeneralSimulationsSummary ----

#' Plot `GeneralSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Graphical display of the general simulation summary.
#'
#' This plot method can be applied to [`GeneralSimulationsSummary`] objects in
#' order to summarize them graphically. Possible `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
#'     `truth` and `target` arguments to [`summary,GeneralSimulations-method`])}
#' }
#' You can specify any subset of these in the `type` argument.
#'
#' @param x (`GeneralSimulationsSummary`)\cr the object we want to plot from.
#' @param y (`missing`)\cr not used.
#' @param type (`character`)\cr the types of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot` object if a single plot is
#'   asked for, otherwise a `gtable` object.
#'
#' @aliases plot-GeneralSimulationsSummary-missing
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "GeneralSimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLTs",
      "nAboveTarget"
    ),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Start the plot list.
    plot_list <- list()
    plot_index <- 0L

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

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

    # Distribution of proportion of DLTs.
    if (x@placebo) {
      if ("propDLTs" %in% type) {
        plot_list[[plot_index <- plot_index + 1L]] <-
          h_barplot_percentages(
            x = x@prop_dlts[1, ] * 100,
            description = "Proportion of DLTs [%] on active",
            xaxisround = 1
          )
      }
    } else {
      if ("propDLTs" %in% type) {
        plot_list[[plot_index <- plot_index + 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) {
      plot_list[[plot_index <- plot_index + 1L]] <-
        h_barplot_percentages(
          x = x@n_above_target,
          description = "Number of patients above target"
        )
    }

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

    # Then return.
    ret
  }
)

# plot-SimulationsSummary ----

#' Plot Model-Based Design Simulation Summary
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Graphical display of the simulation summary.
#'
#' This plot method can be applied to [`SimulationsSummary`] objects in order
#' to summarize them graphically. Possible `type` of plots at the moment are
#' those listed in [`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 `truth` argument to
#'     [`summary,Simulations-method`])}
#' }
#'
#' You can specify any subset of these in the `type` argument.
#'
#' @param x (`SimulationsSummary`)\cr the object we want to plot from.
#' @param y (`missing`)\cr not used.
#' @param type (`character`)\cr the types of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot` object if a single plot is
#'   asked for, otherwise a `gtable` object.
#'
#' @aliases plot-SimulationsSummary-missing
#' @example examples/Simulations-method-plot-SimulationsSummary.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "SimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLTs",
      "nAboveTarget",
      "meanFit"
    ),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Subtract the specific plot types for model-based designs.
    type_reduced <- setdiff(
      type,
      "meanFit"
    )

    # Are there more plots from general?
    more_from_general <- (length(type_reduced) > 0)

    # If so, then produce these plots.
    if (more_from_general) {
      ret <- callNextMethod(x = x, y = y, type = type_reduced)
    }

    # 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.
      this_plot <- ggplot() +
        geom_line(
          aes(
            x = dose,
            y = lines,
            group = group,
            linetype = linetype,
            col = linetype
          ),
          data = dat
        )

      this_plot <- this_plot +
        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 (more_from_general) {
          gridExtra::arrangeGrob(ret, this_plot)
        } else {
          this_plot
        }
    }

    # Then finally plot everything.
    ret
  }
)

# plot-DualSimulationsSummary ----

#' Plot Dual-Endpoint Design Simulation Summary
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Graphical display of dual-endpoint simulation summary.
#'
#' This plot method can be applied to [`DualSimulationsSummary`] objects in
#' order to summarize them graphically. Possible `type` of plots at the moment
#' are those listed in [`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 `trueBiomarker`
#'     argument to [`summary,DualSimulations-method`])}
#' }
#'
#' You can specify any subset of these in the `type` argument.
#'
#' @param x (`DualSimulationsSummary`)\cr the object we want to plot from.
#' @param y (`missing`)\cr not used.
#' @param type (`character`)\cr the types of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot` object if a single plot is
#'   asked for, otherwise a `gtable` object.
#'
#' @aliases plot-DualSimulationsSummary-missing
#' @example examples/Simulations-method-plot-DualSimulationsSummary.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "DualSimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLTs",
      "nAboveTarget",
      "meanFit",
      "meanBiomarkerFit"
    ),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Subtract the specific plot types for dual-endpoint designs.
    type_reduced <- setdiff(
      type,
      "meanBiomarkerFit"
    )

    # Are there more plots from general?
    more_from_general <- (length(type_reduced) > 0)

    # If so, then produce these plots.
    if (more_from_general) {
      ret <- callNextMethod(x = x, y = y, type = type_reduced)
    }

    # 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.
      this_plot <- ggplot() +
        geom_line(
          aes(
            x = dose,
            y = lines,
            group = group,
            linetype = linetype,
            col = linetype
          ),
          data = dat
        )

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

      # Add this plot to the bottom.
      ret <-
        if (more_from_general) {
          gridExtra::arrangeGrob(ret, this_plot, heights = c(2 / 3, 1 / 3))
        } else {
          this_plot
        }
    }

    # Then finally plot everything.
    ret
  }
)

# h_pseudo_sim_inverse_dose ----

#' Helper Function to Calculate Inverse Dose
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Creates an inverse function to find the dose corresponding to a target
#' probability.
#'
#' @param f (`function`)\cr the truth function mapping dose to probability.
#' @param lower (`number`)\cr lower bound for root finding.
#' @param upper (`number`)\cr upper bound for root finding.
#'
#' @return A function that takes a probability and returns the corresponding
#'   dose.
#'
#' @keywords internal
h_pseudo_sim_inverse_dose <- function(f, lower = -100, upper = 100) {
  function(y) {
    uniroot((function(x) f(x) - y), lower = lower, upper = upper)[1]
  }
}

# h_pseudo_sim_fit_summary ----

#' Helper Function to Calculate Fit Summary
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Calculates fit summary statistics for pseudo simulations.
#'
#' @param fit_list (`list`)\cr list of fit objects from simulations.
#' @param x_most_selected (`integer`)\cr index of dose most often selected.
#' @param dose_grid (`numeric`)\cr dose grid.
#' @param truth (`function`)\cr truth function.
#'
#' @return A list with `fit_at_dose_most_selected` and `mean_fit` components.
#'
#' @keywords internal
h_pseudo_sim_fit_summary <- function(
  fit_list,
  x_most_selected,
  dose_grid,
  truth
) {
  # Find names in the fit list (check if with or without samples).
  fit_names <- sapply(fit_list, names)

  if ("probDLE" %in% fit_names) {
    fit_at_dose_most_selected <- sapply(
      fit_list,
      function(f) {
        f$probDLE[x_most_selected]
      }
    )
    mean_fit_matrix <- sapply(
      fit_list,
      "[[",
      "probDLE"
    )

    mean_fit <- list(
      truth = truth(dose_grid),
      average = rowMeans(mean_fit_matrix)
    )
  } else {
    fit_at_dose_most_selected <-
      sapply(
        fit_list,
        function(f) {
          f$middle[x_most_selected]
        }
      )

    # Mean fitted toxicity (average, lower and upper quantiles) at each dose
    # level (this is required for plotting).
    mean_fit_matrix <- sapply(
      fit_list,
      "[[",
      "middle"
    )
    mean_fit <- list(
      truth = truth(dose_grid),
      average = rowMeans(mean_fit_matrix),
      lower = apply(
        mean_fit_matrix,
        1L,
        quantile,
        0.025
      ),
      upper = apply(
        mean_fit_matrix,
        1L,
        quantile,
        0.975
      )
    )
  }

  list(
    fit_at_dose_most_selected = fit_at_dose_most_selected,
    mean_fit = mean_fit
  )
}

# summary-PseudoSimulations ----

#' Summarize `PseudoSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize the simulations, relative to a given truth.
#'
#' @param object (`PseudoSimulations`)\cr the object we want to summarize.
#' @param truth (`function`)\cr a function which takes as input a dose (vector)
#'   and returns the true probability (vector) for toxicity.
#' @param targetEndOfTrial (`number`)\cr the target probability of DLE wanted
#'   to achieve at the end of a trial.
#' @param targetDuringTrial (`number`)\cr the target probability of DLE wanted
#'   to achieve during a trial.
#' @param ... additional arguments can be supplied here for `truth`.
#'
#' @return An object of class [`PseudoSimulationsSummary`].
#'
#' @aliases summary-PseudoSimulations
#' @example examples/Simulations-method-summarySIMsingle.R
#' @export
#'
setMethod(
  f = "summary",
  signature = signature(object = "PseudoSimulations"),
  def = function(
    object,
    truth,
    targetEndOfTrial = 0.3,
    targetDuringTrial = 0.35,
    ...
  ) {
    # Validate arguments.
    assert_function(truth)
    assert_number(targetEndOfTrial, lower = 0, upper = 1)
    assert_number(targetDuringTrial, lower = 0, upper = 1)

    # Extract dose grid.
    dose_grid <- object@data[[1]]@doseGrid

    # Evaluate true DLE at dose grid.
    true_dle <- truth(dose_grid)

    # Function to obtain corresponding dose level given target prob.
    td <- h_pseudo_sim_inverse_dose(truth, 0, max(dose_grid))

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

    # Find the dose corresponding to the target dose end of trial.
    target_dose_during_trial <- as.numeric(td(targetDuringTrial))

    # Find the dose at dose grid corresponding to the above two quantities.
    target_dose_end_of_trial_at_dose_grid <- dose_grid[max(which(
      target_dose_end_of_trial - dose_grid >= 0
    ))]
    target_dose_during_trial_at_dose_grid <- dose_grid[max(which(
      target_dose_during_trial - dose_grid >= 0
    ))]

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

    final_dose_rec_summary <- tdeot_summary

    ratio_tdeot_summary <- summary(object@final_tdeot_ratios)
    final_ratio_summary <- ratio_tdeot_summary

    # A summary for all TDtargetDuringTrial dose obtained.
    tddt_summary <- summary(object@final_td_target_during_trial_estimates)

    # What are the levels above target End of Trial?
    x_above_target_end_of_trial <- which(true_dle > targetEndOfTrial)

    # What are the levels above target During Trial?
    x_above_target_during_trial <- which(true_dle > targetDuringTrial)

    # Proportion of DLEs in this trial.
    prop_dle <- sapply(
      object@data,
      function(d) {
        mean(d@y)
      }
    )

    # Mean toxicity risk.
    mean_tox_risk <- sapply(
      object@data,
      function(d) {
        mean(true_dle[d@xLevel])
      }
    )

    # Doses selected for MTD.
    dose_selected <- object@doses

    # Replace NA by 0.
    dose_selected[is.na(dose_selected)] <- 0

    # Dose most often selected as MTD.
    dose_most_selected <-
      as.numeric(names(which.max(table(dose_selected))))

    x_most_selected <-
      match_within_tolerance(dose_most_selected, table = dose_grid)

    # 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) {
          which_at_this_dose <- which(d@x == dose_most_selected)
          n_at_this_dose <- length(which_at_this_dose)
          n_dlt_at_this_dose <- sum(d@y[which_at_this_dose])
          c(
            nAtThisDose = n_at_this_dose,
            nDLTatThisDose = n_dlt_at_this_dose
          )
        }
      )

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

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

    # Number of patients treated above target End of trial.
    n_above_target_end_of_trial <- sapply(
      object@data,
      function(d) {
        sum(d@xLevel %in% x_above_target_end_of_trial)
      }
    )

    # Number of patients treated above target During trial.
    n_above_target_during_trial <- sapply(
      object@data,
      function(d) {
        sum(d@xLevel %in% x_above_target_during_trial)
      }
    )

    tox_at_doses <- truth(dose_selected)

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

    prop_at_target_end_of_trial <- (length(which(
      object@doses == target_dose_end_of_trial_at_dose_grid
    ))) /
      nsim

    prop_at_target_during_trial <- (length(which(
      object@doses == target_dose_during_trial_at_dose_grid
    ))) /
      nsim

    # Calculate fit summary using helper function.
    fit_summary <- h_pseudo_sim_fit_summary(
      fit_list = object@fit,
      x_most_selected = x_most_selected,
      dose_grid = dose_grid,
      truth = truth
    )

    # Give back an object of class PseudoSimulationsSummary.
    .PseudoSimulationsSummary(
      target_end_of_trial = targetEndOfTrial,
      target_dose_end_of_trial = target_dose_end_of_trial,
      target_during_trial = targetDuringTrial,
      target_dose_during_trial = target_dose_during_trial,
      target_dose_end_of_trial_at_dose_grid = target_dose_end_of_trial_at_dose_grid,
      target_dose_during_trial_at_dose_grid = target_dose_during_trial_at_dose_grid,
      tdeot_summary = tdeot_summary,
      tddt_summary = tddt_summary,
      final_dose_rec_summary = final_dose_rec_summary,
      ratio_tdeot_summary = ratio_tdeot_summary,
      final_ratio_summary = final_ratio_summary,
      nsim = nsim,
      prop_dle = prop_dle,
      mean_tox_risk = mean_tox_risk,
      dose_selected = dose_selected,
      dose_most_selected = dose_most_selected,
      obs_tox_rate_at_dose_most_selected = obs_tox_rate_at_dose_most_selected,
      n_obs = n_obs,
      n_above_target_end_of_trial = n_above_target_end_of_trial,
      n_above_target_during_trial = n_above_target_during_trial,
      tox_at_doses_selected = tox_at_doses,
      prop_at_target_end_of_trial = prop_at_target_end_of_trial,
      prop_at_target_during_trial = prop_at_target_during_trial,
      dose_grid = dose_grid,
      fit_at_dose_most_selected = fit_summary$fit_at_dose_most_selected,
      stop_report = object@stop_report,
      mean_fit = fit_summary$mean_fit
    )
  }
)

# show-PseudoSimulationsSummary ----

#' Show the Summary of `PseudoSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Display a summary of pseudo simulation results.
#'
#' @param object (`PseudoSimulationsSummary`)\cr the object we want to print.
#'
#' @return Invisibly returns a data frame of the results with one row and
#'   appropriate column names.
#'
#' @aliases show-PseudoSimulationsSummary
#' @example examples/Simulations-method-showSIMsingle.R
#' @export
#'
setMethod(
  f = "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@target_end_of_trial * 100,
        "target_end_of_trial"
      ),
      "%\n"
    )

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

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

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

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

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

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

    r$report(
      "prop_dle",
      "Proportions of observed DLT in the trials"
    )
    r$report(
      "mean_tox_risk",
      "Mean toxicity risks for the patients"
    )
    r$report(
      "dose_selected",
      "Doses selected as TDEOT",
      percent = FALSE,
      digits = 1
    )

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

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

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

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

    TDEOTSum <- object@tdeot_summary

    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@ratio_tdeot_summary

    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@tddt_summary

    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"
    )

    final_dose_rec_sum <- object@final_dose_rec_summary

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

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

    final_ratio_sum <- object@final_ratio_summary

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

    cat(
      "The summary table of the final ratios of the optimal dose for stopping across
                  all simulations\n",
      capture.output(final_ratio_sum)[1],
      "\n",
      capture.output(final_ratio_sum)[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-PseudoSimulationsSummary ----

#' Plot `PseudoSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Graphical display of the simulation summary.
#'
#' This plot method can be applied to [`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 (`PseudoSimulationsSummary`)\cr the object we want to plot from.
#' @param y (`missing`)\cr missing object, not used.
#' @param type (`character`)\cr the types of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot2` object if a single plot is asked for, otherwise a
#'   `gtable` object.
#'
#' @aliases plot-PseudoSimulationsSummary-missing
#' @example examples/Simulations-method-plotSUMsingle.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "PseudoSimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLE",
      "nAboveTargetEndOfTrial",
      "meanFit"
    ),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Start the plot list.
    plot_list <- list()
    plot_index <- 0L

    # Distribution of overall sample size.
    if ("nObs" %in% type) {
      plot_list[[plot_index <- plot_index + 1L]] <-
        h_barplot_percentages(
          x = x@n_obs,
          description = "Number of patients in total"
        )
    }

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

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

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

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

    # The meanFit plot.
    if ("meanFit" %in% type) {
      # Find if DLE samples are generated in the simulations by checking if
      # the lower limits of the 95% credibility interval are calculated.
      if (!is.null(x@mean_fit$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@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.
        this_plot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        this_plot <- this_plot +
          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
        # (in percentage) stacked below each other.
        dat <- data.frame(
          dose = rep(x@dose_grid, 2L),
          group = rep(1:2, each = length(x@dose_grid)),
          linetype = factor(
            rep(linetype[c(1, 2)], 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
        )

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

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

        this_plot <- this_plot +
          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 <- if (exists("ret")) {
        gridExtra::arrangeGrob(ret, this_plot)
      } else {
        this_plot
      }
    }
    ret
  }
)

# plot-PseudoDualSimulations ----

#' Plot `PseudoDualSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize the simulations with plots.
#'
#' This plot method can be applied to [`PseudoDualSimulations`] objects in
#' order to summarize them graphically. Possible `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 `type` argument.
#'
#' @param x (`PseudoDualSimulations`)\cr the object we want to plot from.
#' @param y (`missing`)\cr missing object, not used.
#' @param type (`character`)\cr the type of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot2` object if a single plot is asked for, otherwise a
#'   `gtable` object.
#'
#' @aliases plot-PseudoDualSimulations-missing
#' @example examples/Simulations-method-plotSIMDual.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "PseudoDualSimulations",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "trajectory",
      "dosesTried",
      "sigma2"
    ),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Start the plot list.
    plot_list <- list()
    plot_index <- 0L

    # Subtract the specific plot types for dual-endpoint simulation results.
    type_reduced <- setdiff(
      type,
      "sigma2"
    )

    # Are there more plots from general?
    more_from_general <- (length(type_reduced) > 0)

    # If so, then produce these plots.
    if (more_from_general) {
      gen_plot <- callNextMethod(x = x, y = y, type = type_reduced)
    }

    # Now to the specific dual-endpoint plots:
    # Efficacy variance estimates boxplot.
    if ("sigma2" %in% type) {
      # Save the plot.
      plot_list[[plot_index <- plot_index + 1L]] <-
        ggplot(data = data.frame(y = x@sigma2_est), aes(x = factor(0), y = y)) +
        geom_boxplot() +
        coord_flip() +
        scale_x_discrete(breaks = NULL) +
        xlab("") +
        ylab("Efficacy variance estimates")
    }

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

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

    ret
  }
)

# plot-PseudoDualFlexiSimulations ----

#' Plot `PseudoDualFlexiSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize the simulations with plots.
#'
#' This plot method can be applied to [`PseudoDualFlexiSimulations`] objects in
#' order to summarize them graphically. Possible `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 `type` argument.
#'
#' @param x (`PseudoDualFlexiSimulations`)\cr the object we want to plot from.
#' @param y (`missing`)\cr missing object, not used.
#' @param type (`character`)\cr the type of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot2` object if a single plot is asked for, otherwise a
#'   `gtable` object.
#'
#' @aliases plot-PseudoDualFlexiSimulations-missing
#' @example examples/Simulations-method-plotSIMDualFlexi.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "PseudoDualFlexiSimulations",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "trajectory",
      "dosesTried",
      "sigma2",
      "sigma2betaW"
    ),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Start the plot list.
    plot_list <- list()
    plot_index <- 0L

    # Subtract the specific plot types for dual-endpoint simulation results.
    type_reduced <- setdiff(type, "sigma2betaW")

    # Are there more plots from general?
    more_from_general <- (length(type_reduced) > 0)

    # If so, then produce these plots.
    if (more_from_general) {
      gen_plot <- callNextMethod(x = x, y = y, type = type_reduced)
    }

    # Now to the specific dual-endpoint plots:
    # Random walk model variance estimates boxplot.
    if ("sigma2betaW" %in% type) {
      # Save the plot.
      plot_list[[plot_index <- plot_index + 1L]] <-
        ggplot(
          data = data.frame(y = x@sigma2_beta_w_est),
          aes(x = factor(0), y = y)
        ) +
        geom_boxplot() +
        coord_flip() +
        scale_x_discrete(breaks = NULL) +
        xlab("") +
        ylab("Random walk model variance estimates")
    }

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

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

    ret
  }
)

# summary-PseudoDualSimulations ----

#' Summarize `PseudoDualSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summary for Pseudo Dual responses simulations, relative to a given pseudo
#' DLE and efficacy model (except the EffFlexi class model).
#'
#' @param object (`PseudoDualSimulations`)\cr the object we want to summarize.
#' @param trueDLE (`function`)\cr a function which takes as input a dose
#'   (vector) and returns the true probability (vector) of DLE.
#' @param trueEff (`function`)\cr a function which takes as input a dose
#'   (vector) and returns the mean efficacy value(s) (vector).
#' @param targetEndOfTrial (`number`)\cr the target probability of DLE that are
#'   used at the end of a trial. Default at 0.3.
#' @param targetDuringTrial (`number`)\cr the target probability of DLE that
#'   are used during the trial. Default at 0.35.
#' @param ... additional arguments can be supplied here for `trueDLE` and
#'   `trueEff`.
#'
#' @return An object of class [`PseudoDualSimulationsSummary`].
#'
#' @aliases summary-PseudoDualSimulations
#' @example examples/Simulations-method-summarySIMDual.R
#' @export
#'
setMethod(
  f = "summary",
  signature = signature(object = "PseudoDualSimulations"),
  def = function(
    object,
    trueDLE,
    trueEff,
    targetEndOfTrial = 0.3,
    targetDuringTrial = 0.35,
    ...
  ) {
    # Validate arguments.
    assert_function(trueDLE)
    assert_number(targetEndOfTrial, lower = 0, upper = 1)
    assert_number(targetDuringTrial, lower = 0, upper = 1)

    # Call the parent method.
    start <- callNextMethod(
      object = object,
      truth = trueDLE,
      targetEndOfTrial = targetEndOfTrial,
      targetDuringTrial = targetDuringTrial,
      ...
    )
    dose_grid <- object@data[[1]]@doseGrid

    # Dose level most often selected as MTD (TDtargetEnd of Trial).
    x_most_selected <-
      match_within_tolerance(start@dose_most_selected, table = dose_grid)

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

    td_target_end_of_trial <- start@target_dose_end_of_trial

    if (is_true_eff_fx) {
      neg_true_gain_fn <- function(dose) {
        -(trueEff(dose)) / (1 + (trueDLE(dose) / (1 - trueDLE(dose))))
      }
      gstar <- optim(exp(1), neg_true_gain_fn, method = "BFGS")$par
      max_gain_value <- -(optim(
        exp(1),
        neg_true_gain_fn,
        method = "BFGS"
      )$value)
      gstar_at_dose_grid <- dose_grid[max(which(gstar - dose_grid >= 0))]
    } else {
      true_gain <- (trueEff) /
        (1 + (trueDLE(dose_grid) / (1 - trueDLE(dose_grid))))
      max_gain_value <- max(true_gain)
      gstar <- dose_grid[which.max(true_gain)]
      gstar_at_dose_grid <- gstar
    }

    # A summary for all final Gstar obtained.
    gstar_summary <- summary(object@final_gstar_estimates)
    ratio_gstar_summary <- summary(object@final_gstar_ratios)

    final_dose_rec_summary <- summary(object@final_optimal_dose)
    final_ratio_summary <- summary(object@final_ratios)

    # Find names in the fit efficacy list (check if with or without samples).
    fit_names <- sapply(object@fit_eff, names)
    if ("ExpEff" %in% fit_names) {
      # Fitted efficacy level at dose most often selected.
      eff_fit_at_dose_most_selected <- sapply(
        object@fit_eff,
        function(f) {
          f$ExpEff[x_most_selected]
        }
      )
      mean_eff_fit_matrix <- sapply(
        object@fit_eff,
        "[[",
        "ExpEff"
      )

      mean_eff_fit <- list(
        truth = trueEff(dose_grid),
        average = rowMeans(mean_eff_fit_matrix)
      )
    } else {
      # Fitted efficacy level at dose most often selected.
      eff_fit_at_dose_most_selected <-
        sapply(
          object@fit_eff,
          function(f) {
            f$middle[x_most_selected]
          }
        )

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

      # Check if special case applies.
      if (is_true_eff_fx) {
        truth_eff <- trueEff(dose_grid)
      } else {
        truth_eff <- trueEff
      }

      mean_eff_fit <- list(
        truth = truth_eff,
        average = rowMeans(mean_eff_fit_matrix),
        lower = apply(
          mean_eff_fit_matrix,
          1L,
          quantile,
          0.025
        ),
        upper = apply(
          mean_eff_fit_matrix,
          1L,
          quantile,
          0.975
        )
      )
    }

    # Give back an object of class PseudoDualSimulationsSummary.
    .PseudoDualSimulationsSummary(
      start,
      target_gstar = gstar,
      target_gstar_at_dose_grid = gstar_at_dose_grid,
      gstar_summary = gstar_summary,
      ratio_gstar_summary = ratio_gstar_summary,
      final_dose_rec_summary = final_dose_rec_summary,
      final_ratio_summary = final_ratio_summary,
      eff_fit_at_dose_most_selected = eff_fit_at_dose_most_selected,
      mean_eff_fit = mean_eff_fit,
      stop_report = object@stop_report
    )
  }
)

# summary-PseudoDualFlexiSimulations ----

#' Summarize `PseudoDualFlexiSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summary for `PseudoDualFlexiSimulations` given a pseudo DLE model and
#' the flexible efficacy model.
#'
#' @param object (`PseudoDualFlexiSimulations`)\cr the object we want to
#'   summarize.
#' @param trueDLE (`function`)\cr a function which takes as input a dose
#'   (vector) and returns the true probability of DLE (vector).
#' @param trueEff (`numeric`)\cr a vector which takes as input the true mean
#'   efficacy values at all dose levels (in order).
#' @param targetEndOfTrial (`number`)\cr the target probability of DLE that are
#'   used at the end of a trial. Default at 0.3.
#' @param targetDuringTrial (`number`)\cr the target probability of DLE that
#'   are used during the trial. Default at 0.35.
#' @param ... additional arguments can be supplied here for `trueDLE` and
#'   `trueEff`.
#'
#' @return An object of class [`PseudoDualSimulationsSummary`].
#'
#' @aliases summary-PseudoDualFlexiSimulations
#' @example examples/Simulations-method-summarySIMDualFlexi.R
#' @export
#'
setMethod(
  f = "summary",
  signature = signature(object = "PseudoDualFlexiSimulations"),
  def = function(
    object,
    trueDLE,
    trueEff,
    targetEndOfTrial = 0.3,
    targetDuringTrial = 0.35,
    ...
  ) {
    # Validate arguments.
    assert_function(trueDLE)
    assert_multi_class(trueEff, classes = c("numeric", "function"))
    assert_number(targetEndOfTrial, lower = 0, upper = 1)
    assert_number(targetDuringTrial, lower = 0, upper = 1)

    # Call the parent method.
    start <- callNextMethod(
      object = object,
      trueDLE = trueDLE,
      trueEff = trueEff,
      targetEndOfTrial = targetEndOfTrial,
      targetDuringTrial = targetDuringTrial,
      ...
    )

    # Give back an object of class PseudoDualSimulationsSummary.
    .PseudoDualSimulationsSummary(start)
  }
)

# show-PseudoDualSimulationsSummary ----

#' Show the Summary of `PseudoDualSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Display a summary of pseudo dual simulation results.
#'
#' @param object (`PseudoDualSimulationsSummary`)\cr the object we want to print.
#'
#' @return Invisibly returns a data frame of the results with one row and
#'  appropriate column names.
#'
#' @aliases show-PseudoDualSimulationsSummary
#' @example examples/Simulations-method-showSIMDual.R
#' @export
#'
setMethod(
  f = "show",
  signature = signature(object = "PseudoDualSimulationsSummary"),
  def = function(object) {
    # Call the parent method.
    df <- callNextMethod(object)
    df_names <- names(df)

    # Start report object.
    r <- Report$new(
      object = object,
      df = df,
      dfNames = df_names
    )

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

    GstarSum <- object@gstar_summary

    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"
    )

    ratio_gstar_sum <- object@ratio_gstar_summary

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

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

    final_dose_rec_sum <- object@final_dose_rec_summary

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

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

    final_ratio_sum <- object@final_ratio_summary

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

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

    r$report(
      "eff_fit_at_dose_most_selected",
      "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-PseudoDualSimulationsSummary ----

#' Plot `PseudoDualSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Plot the summary of `PseudoDualSimulations`.
#'
#' This plot method can be applied to [`PseudoDualSimulationsSummary`] objects
#' in order to summarize them graphically. Possible `type` of plots at the
#' moment are those listed in [`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 `trueEff` argument to
#'     [`summary,PseudoDualSimulations-method`])}
#' }
#'
#' You can specify any subset of these in the `type` argument.
#'
#' @param x (`PseudoDualSimulationsSummary`)\cr the object we want to plot
#'   from.
#' @param y (`missing`)\cr not used.
#' @param type (`character`)\cr the types of plots you want to obtain.
#' @param ... not used.
#'
#' @return A single `ggplot2` object if a single plot is asked for, otherwise a
#'   `gtable` object.
#'
#' @aliases plot-PseudoDualSimulationsSummary-missing
#' @example examples/Simulations-method-plotSUMDual.R
#' @export
#'
setMethod(
  f = "plot",
  signature = signature(
    x = "PseudoDualSimulationsSummary",
    y = "missing"
  ),
  def = function(
    x,
    y,
    type = c(
      "nObs",
      "doseSelected",
      "propDLE",
      "nAboveTargetEndOfTrial",
      "meanFit",
      "meanEffFit"
    ),
    ...
  ) {
    # Validate arguments.
    type <- match.arg(type, several.ok = TRUE)
    assert_character(type, min.len = 1)

    # Subtract the specific plot types for dual-endpoint designs.
    type_reduced <- setdiff(
      type,
      "meanEffFit"
    )

    # Are there more plots from general?
    more_from_general <- (length(type_reduced) > 0)

    # If so, then produce these plots.
    if (more_from_general) {
      ret <- callNextMethod(x = x, y = y, type = type_reduced)
    }

    # Is the meanEffFit plot requested?
    if ("meanEffFit" %in% type) {
      # Find if Eff samples are generated in the simulations by checking if
      # the lower limits of the 95% credibility interval are calculated.
      if (!is.null(x@mean_eff_fit$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 expected efficacy, average
        # estimated expected efficacy, and 95% (lower, upper) estimated
        # expected efficacy 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_eff_fit)
        )

        # 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.
        this_plot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        this_plot <- this_plot +
          scale_linetype_manual(values = lt) +
          scale_colour_manual(values = col) +
          xlab("Dose level") +
          ylab("Expected Efficacy level")
      } else {
        # Which types of lines do we have?
        linetype <- c(
          "True Expected Efficacy",
          "Average estimated expected efficacy"
        )

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

        # 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.
        this_plot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        this_plot <- this_plot +
          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 (more_from_general) {
          gridExtra::arrangeGrob(ret, this_plot, heights = c(2 / 3, 1 / 3))
        } else {
          this_plot
        }
    }

    # Then finally plot everything.
    ret
  }
)

#' @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.
#' @slot backfilled (`logical`)\cr whether this patient was
#'   in a backfill cohort.
#' @slot response (`integer`)\cr whether this patient had a
#'   positive efficacy response (0 or 1 integers).
#'
#' @aliases Data
#' @export
#'
.Data <- setClass(
  Class = "Data",
  contains = "GeneralData",
  slots = c(
    x = "numeric",
    y = "integer",
    doseGrid = "numeric",
    nGrid = "integer",
    xLevel = "integer",
    placebo = "logical",
    backfilled = "logical",
    response = "integer"
  ),
  prototype = prototype(
    x = numeric(),
    y = integer(),
    doseGrid = numeric(),
    nGrid = 0L,
    xLevel = integer(),
    placebo = FALSE,
    backfilled = logical(),
    response = integer()
  ),
  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 backfilled (`logical`)\cr whether each patient was in
#'   a backfill cohort.
#' @param response (`integer`)\cr whether each patient had a
#'   positive efficacy response (1 = yes, 0 = no). May contain `NA`.
#' @param ... not used.
#'
#' @export
#' @example examples/Data-class.R
#'
Data <- function(
  x = numeric(),
  y = integer(),
  ID = integer(),
  cohort = integer(),
  doseGrid = numeric(),
  placebo = FALSE,
  backfilled = rep(FALSE, length(x)),
  response = rep(NA_integer_, length(x)),
  ...
) {
  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)
  assert_logical(backfilled, len = length(x), any.missing = FALSE)
  assert_integerish(
    response,
    len = length(x),
    lower = 0,
    upper = 1,
    any.missing = TRUE
  )

  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,
    backfilled = backfilled,
    response = as.integer(response)
  )
}

## 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
  )
}

# 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()
  }
)

# match_within_tolerance ----

#' Helper Function for Value Matching with Tolerance
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a modified version of [match()] that supports tolerance.
#'
#' @param x (`numeric`)\cr the values to be matched.
#' @param table (`numeric`)\cr the values to be matched against.
#' @param tolerance (`number`)\cr the numerical tolerance for comparison.
#'
#' @return An integer vector of the same length as `x` giving the position
#'   in `table` of the first match, or an empty integer vector if `table` is empty.
#'   `NA` is returned for values in `x` that have no match.
#'
#' @export
#'
#' @examples
#' match_within_tolerance(c(0.1, 0.2, 0.3), c(0.10000001, 0.5, 0.3))
#' match_within_tolerance(1.5, numeric(0))
match_within_tolerance <- function(x, table, tolerance = 1e-10) {
  assert_numeric(x)
  assert_numeric(table)
  assert_number(tolerance, lower = .Machine$double.xmin, finite = TRUE)

  if (length(table) == 0) {
    integer()
  } else {
    as.integer(vapply(
      x,
      function(val) {
        matches <- vapply(
          table,
          function(tbl_val) {
            isTRUE(all.equal(
              val,
              tbl_val,
              tolerance = tolerance,
              check.names = FALSE,
              check.attributes = FALSE
            ))
          },
          logical(1)
        )
        which(matches)[1L]
      },
      integer(1)
    ))
  }
}

# logit ----

#' Shorthand for Logit Function
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Computes the logit transformation.
#'
#' @param x (`numeric`)\cr the function argument.
#'
#' @return The logit of `x`, computed as `log(x / (1 - x))`.
#'
#' @export
#'
#' @examples
#' logit(0.5)
#' logit(c(0.1, 0.5, 0.9))
logit <- function(x) {
  qlogis(x)
}

# probit ----

#' Shorthand for Probit Function
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Computes the probit (inverse cumulative distribution function of standard normal) transformation.
#'
#' @param x (`numeric`)\cr the function argument.
#'
#' @return The probit of `x`, the quantile function of the standard normal distribution.
#'
#' @export
#'
#' @examples
#' probit(0.5)
#' probit(c(0.025, 0.5, 0.975))
probit <- function(x) {
  qnorm(x)
}

# crmPackExample ----

#' Open the Example PDF for crmPack
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Calling this helper function opens the `example.pdf` document,
#' residing in the `doc` subfolder of the package installation directory.
#'
#' @return Called for side effects.
#'
#' @export
crmPackExample <- function() {
  crm_path <- system.file(package = "crmPack")
  printVignette(list(PDF = "example.pdf", Dir = crm_path))
}

# crmPackHelp ----

#' Open the Browser with Help Pages for crmPack
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This convenience function opens your browser with the help pages for crmPack.
#'
#' @return Called for side effects.
#'
#' @export
#' @importFrom utils help
crmPackHelp <- function() {
  utils::help(package = "crmPack", help_type = "html")
}

# plot.gtable ----

#' Plot `gtable` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' 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.
#'
#' @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, ...)
}

# print.gtable ----

#' @method print gtable
#' @param x (`gtable`)\cr object to print.
#' @param ... additional parameters passed to [plot.gtable()].
#' @rdname plot.gtable
#' @return Called for side effects.
#' @export
print.gtable <- function(x, ...) {
  plot(x, ...)
}

# printVignette ----

#' Print Vignette
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Taken from utils package (`print.vignette`).
#'
#' @param x (`list`)\cr vignette information.
#' @param ... not used.
#'
#' @return `x` invisibly.
#'
#' @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") {
      pdf_viewer <- getOption("pdfviewer")
      if (identical(pdf_viewer, "false")) {} else if (
        .Platform$OS.type == "windows" &&
          identical(pdf_viewer, file.path(R.home("bin"), "open.exe"))
      ) {
        shell.exec(out)
      } else {
        system2(pdf_viewer, 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)
}

# dinvGamma ----

#' Compute the Density of Inverse Gamma Distribution
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param x (`numeric`)\cr vector of quantiles.
#' @param a (`number`)\cr the shape parameter of the inverse gamma distribution.
#' @param b (`number`)\cr the scale parameter of the inverse gamma distribution.
#' @param log (`flag`)\cr if `TRUE`, probabilities `p` are given as `log(p)`.
#' @param normalize (`flag`)\cr if `TRUE`, the output will be normalized.
#'
#' @return The density value(s).
#'
#' @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) {
    ret
  } else {
    exp(ret)
  }
}

# pinvGamma ----

#' Compute the Distribution Function of Inverse Gamma Distribution
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param q (`numeric`)\cr vector of quantiles.
#' @param a (`number`)\cr the shape parameter of the inverse gamma distribution.
#' @param b (`number`)\cr the scale parameter of the inverse gamma distribution.
#' @param lower.tail (`flag`)\cr if `TRUE` (default), probabilities are `P(X <= x)`,
#'   otherwise, `P(X > x)`.
#' @param log.p (`flag`)\cr if `TRUE`, probabilities/densities `p` are returned as `log(p)`.
#'
#' @return The distribution function value(s).
#'
#' @keywords internal
# nolint start
pinvGamma <- function(q, a, b, lower.tail = TRUE, log.p = FALSE) {
  # nolint end
  pgamma(
    q = 1 / q,
    shape = a,
    rate = b,
    lower.tail = !lower.tail,
    log.p = log.p
  )
}

# qinvGamma ----

#' Compute the Quantile Function of Inverse Gamma Distribution
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param p (`numeric`)\cr vector of probabilities.
#' @param a (`number`)\cr the shape parameter of the inverse gamma distribution.
#' @param b (`number`)\cr the scale parameter of the inverse gamma distribution.
#' @param lower.tail (`flag`)\cr if `TRUE` (default), probabilities are `P(X <= x)`,
#'   otherwise, `P(X > x)`.
#' @param log.p (`flag`)\cr if `TRUE`, probabilities/densities `p` are given as `log(p)`.
#'
#' @return The quantile value(s).
#'
#' @keywords internal
# nolint start
qinvGamma <- function(p, a, b, lower.tail = TRUE, log.p = FALSE) {
  # nolint end
  1 /
    qgamma(
      p = p,
      shape = a,
      rate = b,
      lower.tail = !lower.tail,
      log.p = log.p
    )
}

# rinvGamma ----

#' Random Generation for the Inverse Gamma Distribution
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param n (`count`)\cr the number of observations.
#' @param a (`number`)\cr the shape parameter of the inverse gamma distribution.
#' @param b (`number`)\cr the scale parameter of the inverse gamma distribution.
#'
#' @return A vector of random values from the inverse gamma distribution.
#'
#' @keywords internal
rinvGamma <- function(n, a, b) {
  1 / rgamma(n, shape = a, rate = b)
}

#' 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-06) {
  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)) {
      # Use Cholesky decomposition which is more robust than eigenvalue computation
      chol_result <- try(chol(x), silent = TRUE)
      !inherits(chol_result, "try-error")
    } 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
  )
}

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

# Opening ----

## class ----

#' `Opening`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`Opening`] is a virtual class for opening criteria, from which all
#' other specific opening criteria classes inherit.
#' The subclasses are used for backfill cohort designs.
#'
#' @seealso [`OpeningMinDose`], [`OpeningMinCohorts`], [`OpeningNone`],
#'   [`OpeningMinResponses`], [`OpeningAll`], [`OpeningAny`].
#'
#' @aliases Opening
#' @export
#'
.Opening <- setClass(
  Class = "Opening",
  contains = "CrmPackClass"
)

## default constructor ----

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

# OpeningMinDose ----

## class ----

#' `OpeningMinDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`OpeningMinDose`] opens a backfill cohort when the
#' cohort's dose is above or equal to the minimum dose specified.
#' Note that the next recommended dose is not taken into account.
#'
#' @slot min_dose (`number`)\cr the minimum dose at which backfill
#'   cohorts can be opened.
#'
#' @seealso [`Opening`] and the other subclasses listed in there.
#'
#' @aliases OpeningMinDose
#' @export
.OpeningMinDose <- setClass(
  Class = "OpeningMinDose",
  slots = c(min_dose = "numeric"),
  prototype = list(min_dose = 0),
  contains = "Opening",
  validity = v_opening_min_dose
)

## constructor ----

#' @rdname OpeningMinDose-class
#'
#' @param min_dose (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Backfill-class-OpeningMinDose.R
OpeningMinDose <- function(min_dose = 0) {
  .OpeningMinDose(min_dose = min_dose)
}

## default constructor ----

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

# OpeningMinCohorts ----

## class ----

#' `OpeningMinCohorts`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`OpeningMinCohorts`] opens backfill cohorts when the overall number of
#' cohorts treated so far in the trial reaches or exceeds a minimum threshold.
#' This can be used to implement a "delayed backfill cohort opening" rule.
#'
#' @slot min_cohorts (`integer`)\cr the minimum number of cohorts that must
#'   have been treated before backfilling can be opened.
#'
#' @seealso [`Opening`] and the other subclasses listed in there.
#'
#' @aliases OpeningMinCohorts
#' @export
#'
.OpeningMinCohorts <- setClass(
  Class = "OpeningMinCohorts",
  slots = c(min_cohorts = "integer"),
  prototype = list(min_cohorts = 2L),
  contains = "Opening",
  validity = v_opening_min_cohorts
)

## constructor ----

#' @rdname OpeningMinCohorts-class
#'
#' @param min_cohorts (`integer`)\cr see slot definition.
#'
#' @export
#'
OpeningMinCohorts <- function(min_cohorts = 2L) {
  assert_integerish(min_cohorts, len = 1, lower = 1)
  min_cohorts <- as.integer(min_cohorts)
  .OpeningMinCohorts(min_cohorts = min_cohorts)
}

## default constructor ----

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

# OpeningNone ----

## class ----

#' `OpeningNone`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`OpeningNone`] never opens any backfill cohorts. This can be used when
#' no backfill cohorts should be available in a trial design.
#'
#' @aliases OpeningNone
#' @export
#'
.OpeningNone <- setClass(
  Class = "OpeningNone",
  contains = "Opening"
)

## constructor ----

#' @rdname OpeningNone-class
#'
#' @export
#'
OpeningNone <- function() {
  .OpeningNone()
}

## default constructor ----

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

# OpeningMinResponses ----

## class ----

#' `OpeningMinResponses`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`OpeningMinResponses`] opens backfill cohorts when a minimum number of
#' responses has been observed in the trial. The responses can be counted
#' at the cohort's dose level only, or also at lower dose levels if
#' `include_lower_doses` is set to `TRUE`.
#'
#' @slot min_responses (`count`)\cr the minimum number of responses
#'   required before backfill cohorts can be opened (at least 1).
#' @slot include_lower_doses (`logical`)\cr if `TRUE`, responses at all
#'   doses less than or equal to the cohort's dose are counted. If `FALSE`,
#'   only responses at the cohort's dose are counted.
#'
#' @seealso [`Opening`] and the other subclasses listed in there.
#'
#' @aliases OpeningMinResponses
#' @export
#'
.OpeningMinResponses <- setClass(
  Class = "OpeningMinResponses",
  slots = c(
    min_responses = "integer",
    include_lower_doses = "logical"
  ),
  prototype = list(
    min_responses = 1L,
    include_lower_doses = FALSE
  ),
  contains = "Opening",
  validity = v_opening_min_responses
)

## constructor ----

#' @rdname OpeningMinResponses-class
#'
#' @param min_responses (`count`)\cr see slot definition.
#' @param include_lower_doses (`logical`)\cr see slot definition.
#'
#' @export
#' @example examples/Backfill-class-OpeningMinResponses.R
OpeningMinResponses <- function(
  min_responses = 1L,
  include_lower_doses = FALSE
) {
  assert_count(min_responses, positive = TRUE)
  assert_flag(include_lower_doses)
  min_responses <- as.integer(min_responses)
  .OpeningMinResponses(
    min_responses = min_responses,
    include_lower_doses = include_lower_doses
  )
}

## default constructor ----

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


# OpeningList and logical operators ----

## OpeningList ----

#' `OpeningList`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`OpeningList`] is a virtual class for combining multiple [`Opening`] objects
#' using logical operators. It is used as a base class for [`OpeningAll`] and
#' [`OpeningAny`].
#'
#' @slot open_list (`list`)
#'   a list of [`Opening`] objects to be combined.
#'
#' @seealso [`Opening`], [`OpeningAll`], [`OpeningAny`].
#'
#' @aliases OpeningList
#' @export
#'
.OpeningList <- setClass(
  Class = "OpeningList",
  contains = "Opening",
  slots = list(open_list = "list")
)

## constructor ----

#' @rdname OpeningList-class
#'
#' @param ... (`Opening`)\cr opening objects to combine.
#' @export
#' @example examples/Backfill-class-OpeningList.R
OpeningList <- function(...) {
  args <- list(...)
  assert_list(args, min.len = 1)
  for (arg in args) {
    assert_class(arg, "Opening")
  }
  .OpeningList(open_list = args)
}

## default constructor ----

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

## OpeningAll ----

#' `OpeningAll`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`OpeningAll`] combines multiple [`Opening`] objects using AND logic.
#' A backfill cohort is opened only if ALL opening criteria in the list
#' are satisfied. This can also be created using the `&` operator.
#'
#' @slot open_list (`list`)
#'   a list of [`Opening`] objects to be combined with AND logic.
#'
#' @seealso [`Opening`], [`OpeningAny`], [`OpeningList`].
#'
#' @aliases OpeningAll
#' @export
#'
.OpeningAll <- setClass(
  Class = "OpeningAll",
  contains = "OpeningList"
)

## constructor ----

#' @rdname OpeningAll-class
#'
#' @param ... (`Opening`)
#'   opening objects to combine with AND logic.
#'
#' @export
#' @example examples/Backfill-class-OpeningAll.R
OpeningAll <- function(...) {
  start <- OpeningList(...)
  .OpeningAll(start)
}

## default constructor ----

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

## OpeningAny ----

#' `OpeningAny`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`OpeningAny`] combines multiple [`Opening`] objects using OR logic.
#' A backfill cohort is opened if ANY opening criteria in the list
#' are satisfied. This can also be created using the `|` operator.
#'
#' @slot open_list (`list`)\cr a list of [`Opening`] objects to be
#'   combined with OR logic.
#'
#' @seealso [`Opening`], [`OpeningAll`], [`OpeningList`].
#'
#' @aliases OpeningAny
#' @export
#'
.OpeningAny <- setClass(
  Class = "OpeningAny",
  contains = "OpeningList"
)

## constructor ----

#' @rdname OpeningAny-class
#'
#' @param ... (`Opening`)
#'   opening objects to combine with OR logic.
#'
#' @export
#' @example examples/Backfill-class-OpeningAny.R
OpeningAny <- function(...) {
  start <- OpeningList(...)
  .OpeningAny(start)
}

## default constructor ----

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

# Recruitment ----

## class ----

#' `Recruitment`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`Recruitment`] is a virtual class for recruitment criteria, from which all
#' other specific recruitment criteria classes inherit.
#' The subclasses are used to specify the maximum number of backfill patients
#' that can be recruited relative to the main trial cohort size.
#'
#' @seealso [`RecruitmentUnlimited`], [`RecruitmentRatio`].
#'
#' @aliases Recruitment
#' @export
#'
.Recruitment <- setClass(
  Class = "Recruitment",
  contains = "CrmPackClass"
)

## default constructor ----

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

# RecruitmentUnlimited ----

## class ----

#' `RecruitmentUnlimited`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`RecruitmentUnlimited`] allows unlimited recruitment of backfill patients.
#' There is no constraint on the number of backfill patients relative to the
#' main trial cohort size.
#'
#' @seealso [`Recruitment`] and the other subclasses listed in there.
#'
#' @aliases RecruitmentUnlimited
#' @export
#'
.RecruitmentUnlimited <- setClass(
  Class = "RecruitmentUnlimited",
  contains = "Recruitment"
)

## constructor ----

#' @rdname RecruitmentUnlimited-class
#'
#' @export
#' @example examples/Backfill-class-RecruitmentUnlimited.R
RecruitmentUnlimited <- function() {
  .RecruitmentUnlimited()
}

## default constructor ----

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

# RecruitmentRatio ----

## class ----

#' `RecruitmentRatio`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`RecruitmentRatio`] constrains the recruitment of backfill patients
#' based on a ratio to the main trial cohort size. The maximum number of
#' backfill patients is calculated as `ceiling(ratio * active_cohort_size)`.
#'
#' @slot ratio (`number`)
#'   the recruitment ratio, specifying the maximum number of backfill patients
#'   per patient in the main trial cohort (non-negative).
#'
#' @seealso [`Recruitment`] and the other subclasses listed in there.
#'
#' @aliases RecruitmentRatio
#' @export
#'
.RecruitmentRatio <- setClass(
  Class = "RecruitmentRatio",
  contains = "Recruitment",
  slots = list(ratio = "numeric"),
  validity = v_recruitment_ratio
)

## constructor ----

#' @rdname RecruitmentRatio-class
#'
#' @param ratio (`number`)
#'   see slot definition.
#'
#' @export
#' @example examples/Backfill-class-RecruitmentRatio.R
RecruitmentRatio <- function(ratio = 1) {
  assert_numeric(ratio, len = 1, lower = 0)
  .RecruitmentRatio(ratio = ratio)
}

## default constructor ----

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

# Backfill ----

## class ----

#' `Backfill` class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Class representing a backfilling rule in a clinical trial design.
#'
#' @slot cohort_size (`CohortSize`)\cr the size of cohorts to be backfilled.
#' @slot opening (`Opening`)\cr the opening criteria for backfilling.
#' @slot recruitment (`Recruitment`)\cr recruitment criteria for backfilling.
#' @slot max_size (`count`)\cr the maximum number of patients to be backfilled.
#' @slot priority (`character`)\cr the priority rule for backfilling,
#'   one of "highest", "lowest", or "random".
#'
#' @aliases Backfill
#' @export
.Backfill <- setClass(
  Class = "Backfill",
  slots = list(
    cohort_size = "CohortSize",
    opening = "Opening",
    recruitment = "Recruitment",
    max_size = "integer",
    priority = "character"
  ),
  prototype = prototype(
    cohort_size = CohortSizeConst(size = 3),
    opening = .OpeningMinDose(),
    recruitment = .RecruitmentUnlimited(),
    max_size = 1e6L,
    priority = "highest"
  ),
  contains = "CrmPackClass",
  validity = v_backfill
)

## constructor ----

#' @rdname Backfill-class
#'
#' @param cohort_size (`CohortSize`)\cr see the slot definition.
#' @param opening (`Opening`)\cr see the slot definition.
#' @param recruitment (`Recruitment`)\cr see the slot definition.
#' @param max_size (`count`)\cr see the slot definition.
#' @param priority (`character`)\cr see the slot definition.
#' @return An object of class `Backfill`.
#'
#' @export
Backfill <- function(
  cohort_size = CohortSizeConst(size = 3),
  opening = OpeningMinDose(),
  recruitment = RecruitmentUnlimited(),
  max_size = 1e6L,
  priority = c("highest", "lowest", "random")
) {
  assert_count(max_size, positive = TRUE)
  max_size <- as.integer(max_size)
  priority <- match.arg(priority)

  .Backfill(
    cohort_size = cohort_size,
    opening = opening,
    recruitment = recruitment,
    max_size = max_size,
    priority = priority
  )
}

## default constructor ----

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

#' 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
  )
}

#' @include Design-validity.R
#' @include Model-class.R
#' @include Rules-class.R
#' @include Backfill-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).
#' @slot backfill (`Backfill`)\cr rules for backfilling patients in the trial
#'   (defaults to no backfilling).
#'
#' @aliases Design
#' @export
#'
.Design <- setClass(
  Class = "Design",
  slots = c(
    model = "GeneralModel",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize",
    backfill = "Backfill"
  ),
  prototype = prototype(
    model = .LogisticNormal(),
    nextBest = .NextBestNCRM(),
    stopping = .StoppingMinPatients(),
    increments = .IncrementsRelative(),
    pl_cohort_size = CohortSizeConst(0L),
    backfill = .Backfill(opening = .OpeningNone())
  ),
  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.
#' @param backfill (`Backfill`)\cr see slot definition.
#' @inheritDotParams RuleDesign
#'
#' @export
#' @example examples/Design-class-Design.R
#'
#'
Design <- function(
  model,
  stopping,
  increments,
  pl_cohort_size = CohortSizeConst(0L),
  backfill = Backfill(opening = OpeningNone()),
  ...
) {
  start <- RuleDesign(...)
  new(
    "Design",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size,
    backfill = backfill
  )
}

## 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.
#'
#' @details Please note that the cohort size rules need to be wrapped into
#' the corresponding [CohortSizeOrdinal] class, before a successful evaluation of the
#' corresponding methods can take place. Note also that these wrappers cannot be nested,
#' i.e., you cannot have a [CohortSizeOrdinal] inside another [CohortSizeOrdinal]
#' (which also would not make sense) because it would not be clear which event grade to use
#' for the methods calculation. However, multiple rules can be combined using the operators
#' defined, e.g.,
#' `CohortSizeMin(list(CohortSizeOrdinal(1L, rule1), CohortSizeOrdinal(2L, rule2)))`.
#'
#' @slot next_best (`NextBestOrdinal`)\cr how to find the next best dose.
#' @slot cohort_size (`CohortSize`)\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 = "CohortSize",
    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 (`CohortSize`)\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.
#'
#' @details Please note that stopping, increments or cohort size rules need to be wrapped into
#' the corresponding [StoppingOrdinal], [IncrementsOrdinal] or [CohortSizeOrdinal] classes, before
#' a successful evaluation of the corresponding methods can take place.
#' Note also that these wrappers cannot be nested, i.e., you cannot have an [IncrementsOrdinal] inside
#' another [IncrementsOrdinal] (which also would not make sense) because it would not be clear which
#' event grade to use for the methods calculation.
#' However, multiple rules can be combined using the operators defined for these classes, e.g.,
#' `StoppingOrdinal(1L, rule1 & rule2) | StoppingOrdinal(2L, rule3)`.
#'
#' @slot model (`LogisticLogNormalOrdinal`)\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 DesignOrdinal
#' @export
#'
.DesignOrdinal <- setClass(
  Class = "DesignOrdinal",
  slots = c(
    model = "LogisticLogNormalOrdinal",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize"
  ),
  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 (`Stopping`)\cr see slot definition.
#' @param increments (`Increments`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSize`)\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.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,
      ...
    )
  }
)

# mcmc-DataMixture ----

#' @describeIn mcmc Method for [`DataMixture`] with different `from_prior` default.
#'   Samples from the prior only when both the number of observations and the
#'   number of shared observations are zero.
#'
#' @aliases mcmc-DataMixture
#'
setMethod(
  f = "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, ...)
  }
)

# myBayesLogit ----

#' MCMC Sampling for Bayesian Logistic Regression Model
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Replacement for `BayesLogit::logit`. Performs MCMC sampling for Bayesian
#' logistic regression using JAGS.
#'
#' @param y (`integer`)\cr 0/1 vector of responses.
#' @param X (`matrix`)\cr design matrix.
#' @param m0 (`numeric`)\cr prior mean vector.
#' @param P0 (`matrix`)\cr precision matrix.
#' @param options (`McmcOptions`)\cr MCMC options.
#'
#' @return The matrix of samples (samples x parameters).
#'
#' @keywords internal
myBayesLogit <- function(y, X, m0, P0, options) {
  # Assertions.
  p <- length(m0)
  n_obs <- length(y)
  assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE, len = n_obs)
  assert_numeric(m0, any.missing = FALSE, len = p)
  assert_matrix(P0, mode = "numeric", any.missing = FALSE, nrows = p, ncols = p)
  assert_matrix(
    X,
    mode = "numeric",
    any.missing = FALSE,
    nrows = n_obs,
    ncols = p
  )
  assert_class(options, "McmcOptions")

  # Get or set the seed.
  r_seed <- try(get(".Random.seed", envir = .GlobalEnv), silent = TRUE)
  if (is(r_seed, "try-error")) {
    set.seed(floor(runif(n = 1, min = 0, max = 1e4)))
    r_seed <- 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.
  r_seed <- abs(r_seed[-c(1:2)][r_seed[2]])

  # Build the JAGS model.
  bugs_model <- 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.
  model_file_name <- h_jags_write_model(bugs_model)

  jags_model <- rjags::jags.model(
    model_file_name,
    data = list(
      "X" = X,
      "y" = y,
      "nObs" = n_obs,
      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 = r_seed
    ),
    n.chains = 1,
    n.adapt = 0
  )

  # Burn in.
  update(jags_model, n.iter = options@burnin, progress.bar = "none")

  # Generate samples.
  # This is necessary because some outputs are written directly from the JAGS
  # compiled code to the outstream.
  samples <- NULL
  capture.output(
    samples <- rjags::jags.samples(
      model = jags_model,
      variable.names = "beta",
      n.iter = (options@iterations - options@burnin),
      thin = options@step,
      progress.bar = "none"
    )
  )

  t(samples$beta[,, 1L])
}


# mcmc-Data-LogisticIndepBeta ----

#' @describeIn mcmc Obtain posterior samples for the model parameters based on
#'   the pseudo [`LogisticIndepBeta`] 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
#'   \insertCite{WhiteheadWilliamson1998;textual}{crmPack}. However, since
#'   asymptotically, the joint posterior probability density will be bivariate
#'   normal, we use the bivariate normal distribution to generate posterior
#'   samples of the intercept and the slope parameters. For the prior samples of
#'   the intercept and the slope, a bivariate normal distribution with mean and
#'   the covariance matrix given in
#'   \insertCite{WhiteheadWilliamson1998;textual}{crmPack} is used.
#'
#' @aliases mcmc-Data-LogisticIndepBeta
#' @example examples/mcmc-LogisticIndepBeta.R
#' @references
#'   \insertAllCited{}
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "Data",
    model = "LogisticIndepBeta",
    options = "McmcOptions"
  ),
  def = function(data, model, options, ...) {
    # Update the DLE model first.
    this_model <- 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 <- (this_model@binDLE) / (this_model@DLEweights)
    # Scalar term for the covariance matrix.
    scalar_i <- this_model@DLEweights * pi * (1 - pi)

    precision <- matrix(rep(0, 4), nrow = 2, ncol = 2)

    for (i in seq_len(length(this_model@binDLE))) {
      precision_mat <- scalar_i[i] *
        matrix(
          c(
            1,
            log(this_model@DLEdose[i]),
            log(this_model@DLEdose[i]),
            (log(this_model@DLEdose[i]))^2
          ),
          2,
          2
        )
      precision <- precision + precision_mat
    }

    if (from_prior) {
      # Sample from the (asymptotic) bivariate normal prior for theta.
      tmp <- mvtnorm::rmvnorm(
        n = size(options),
        mean = c(slot(this_model, "phi1"), slot(this_model, "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.
      scalar_i <- weights * pi * (1 - pi)

      prior_dle <- this_model@binDLE
      prior_w1 <- this_model@DLEweights
      prior_dose <- this_model@DLEdose

      fit_dle <- suppressWarnings(glm(
        prior_dle / prior_w1 ~ log(prior_dose),
        family = binomial(link = "logit"),
        weights = prior_w1
      ))
      s_fit_dle <- summary(fit_dle)

      # Obtain parameter estimates for dose-DLE curve.
      prior_phi1 <- coef(s_fit_dle)[1, 1]
      prior_phi2 <- coef(s_fit_dle)[2, 1]

      # Use fast special sampler here.
      # Set up design matrix.
      X <- cbind(1, log(data@x))
      init_res <- myBayesLogit(
        y = data@y,
        X = X,
        m0 = c(prior_phi1, prior_phi2),
        P0 = precision,
        options = options
      )

      # Form the samples list.
      samples <- list(
        phi1 = init_res[, 1],
        phi2 = init_res[, 2]
      )
    }

    # Form a Samples object for return.
    Samples(
      data = samples,
      options = options
    )
  }
)

# mcmc-DataDual-Effloglog ----

#' @describeIn mcmc Obtain the posterior samples for the model parameters in the
#'   [`Effloglog`] 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 `nu` samples will be used to generate samples of the
#'   intercept and slope parameters of the model.
#'
#' @aliases mcmc-DataDual-Effloglog
#' @example examples/mcmc-Effloglog.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "DataDual",
    model = "Effloglog",
    options = "McmcOptions"
  ),
  def = 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
    )
  }
)

# mcmc-DataDual-EffFlexi ----

#' @describeIn mcmc Obtain the posterior samples for the estimates in the
#'   [`EffFlexi`] model. This is the MCMC procedure based on what is described
#'   in \insertCite{LangBrezger2004;textual}{crmPack} 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
#'   \insertCite{LangBrezger2004;textual}{crmPack} 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 have 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.
#'
#' @aliases mcmc-DataDual-EffFlexi
#' @example examples/mcmc-EffFlexi.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "DataDual",
    model = "EffFlexi",
    options = "McmcOptions"
  ),
  def = function(data, model, options, ...) {
    # Update the model.
    this_model <- update(object = model, data = data)

    n_samples <- size(options)

    # Prepare samples container.
    samples <- list(
      ExpEff = matrix(ncol = data@nGrid, nrow = n_samples),
      sigma2W = matrix(nrow = n_samples),
      sigma2betaW = matrix(nrow = n_samples)
    )

    # Index of the next sample to be saved.
    iter_save <- 1L

    # Monitoring the Metropolis-Hastings update for sigma2.
    accept_history <- list(sigma2W = logical(options@iterations))

    # Current parameter values and starting values for the MCMC.
    if (length(data@w) == 0) {
      w1 <- this_model@eff
      x1 <- this_model@eff_dose
    } else {
      # Combine pseudo data with observed efficacy responses and no DLT observed.
      eff_obsrv <- getEff(data, no_dlt = TRUE)
      w1 <- c(this_model@eff, eff_obsrv$w_no_dlt)
      x1 <- c(this_model@eff_dose, eff_obsrv$x_no_dlt)
    }
    x1_level <- match_within_tolerance(x1, data@doseGrid)

    # betaW is constant, the average of the efficacy values.
    beta_w <- rep(mean(w1), data@nGrid)

    # sigma2betaW: use fixed value or prior mean.
    sigma2_beta_w <-
      if (this_model@use_fixed[["sigma2betaW"]]) {
        this_model@sigma2betaW
      } else {
        this_model@sigma2betaW["b"] / (this_model@sigma2betaW["a"] - 1)
      }

    # sigma2: fixed value or just the empirical variance.
    sigma2_w <- if (this_model@use_fixed[["sigma2W"]]) {
      this_model@sigma2W
    } else {
      var(w1)
    }

    # Set up diagonal matrix with the number of patients in corresponding dose levels.
    design_w_crossprod <- crossprod(this_model@X)

    # The MCMC cycle.
    for (iter_mcmc in seq_len(options@iterations)) {
      # 1) Generate coefficients for the Flexible Efficacy model.
      adjusted_var <- sigma2_w
      # New precision matrix.
      this_prec_w <- design_w_crossprod /
        adjusted_var +
        this_model@RW / sigma2_beta_w
      # Draw random normal vector.
      norm_vec <- rnorm(data@nGrid)
      # And its Cholesky factor.
      this_prec_w_chol <- chol(this_prec_w)
      # Solve betaW for L^T * betaW = normVec.
      beta_w <- backsolve(r = this_prec_w_chol, x = norm_vec)
      # The residual.
      adjusted_w <- w1 - this_model@X %*% beta_w

      # Forward substitution: solve L^T * tmp = designW^T * adjustedW / adjustedVar.
      tmp <- forwardsolve(
        l = this_prec_w_chol,
        x = crossprod(this_model@X, adjusted_w) / adjusted_var,
        upper.tri = TRUE,
        transpose = TRUE
      )
      # Backward substitution: solve R * result = tmp (where R is the Cholesky factor).
      tmp <- backsolve(
        r = this_prec_w_chol,
        x = tmp
      )

      # tmp is the mean vector of the distribution.
      # Add tmp to betaW to obtain final sample.
      beta_w <- beta_w + tmp

      # 2) Generate prior variance factor for the random walk.
      # If fixed, do nothing. Otherwise sample from full conditional.
      if (!this_model@use_fixed[["sigma2betaW"]]) {
        sigma2_beta_w <- rinvGamma(
          n = 1L,
          a = this_model@sigma2betaW["a"] + this_model@RW_rank / 2,
          b = this_model@sigma2betaW["b"] +
            crossprod(beta_w, this_model@RW %*% beta_w) / 2
        )
      }

      # 3) Generate variance for the flexible efficacy model.
      # If fixed variance is used, do nothing.
      if (this_model@use_fixed[["sigma2W"]]) {
        accept_history$sigma2W[iter_mcmc] <- TRUE
      } else {
        # Metropolis-Hastings update step here, using an inverse gamma distribution.
        a_star <- this_model@sigma2W["a"] + length(x1) / 2
        # Second parameter bStar depends on the value for sigma2W.
        b_star <- function(x) {
          adj_w <- w1
          sum((adj_w - beta_w[x1_level])^2) / 2 + this_model@sigma2W["b"]
        }
        # Draw proposal.
        b_star_proposal <- b_star(sigma2_w)
        sigma2_w <- rinvGamma(n = 1L, a = a_star, b = b_star_proposal)
      }

      # 4) Save samples.
      if (saveSample(options, iter_mcmc)) {
        samples$ExpEff[iter_save, ] <- beta_w
        samples$sigma2W[iter_save, 1] <- sigma2_w
        samples$sigma2betaW[iter_save, 1] <- sigma2_beta_w
        iter_save <- iter_save + 1L
      }
    }

    Samples(
      data = samples,
      options = options
    )
  }
)

# mcmc-DataOrdinal-LogisticLogNormalOrdinal ----

#' @describeIn mcmc Obtain the posterior samples for the model parameters in the
#'   [`LogisticLogNormalOrdinal`] model.
#'
#'   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.
#'
#' @aliases mcmc-DataOrdinal-LogisticLogNormalOrdinal
#' @example examples/mcmc-LogisticLogNormalOrdinal.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "DataOrdinal",
    model = "LogisticLogNormalOrdinal",
    options = "McmcOptions"
  ),
  def = 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
  }
)

# 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 <- h_kable_param_default(
    list(...),
    col_names = c("Lower", "Upper", "Cohort size"),
    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)
  tox_label <- h_prepare_labels(tox_label)

  param <- h_kable_param_default(
    list(...),
    col_names = c("Lower", "Upper", "Cohort size"),
    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
}

#' Render a `CohortSizeRandom` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @inheritSection knit_print.CohortSizeConst Usage Notes
#'
#' @export
#' @method knit_print CohortSizeRandom
#' @rdname knit_print
knit_print.CohortSizeRandom <- function(
  x,
  ...,
  asis = TRUE,
  label = c("participant", "participants")
) {
  assert_flag(asis)

  label <- h_prepare_labels(label)
  rv <- paste0(
    "A random cohort size drawn uniformly between ",
    x@min_size,
    " and ",
    x@max_size,
    " ",
    label[2],
    ".\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @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
}

#' @include helpers_data.R

# subsetting ----

## Data ----

#' @title Subsetting Operator for the Data Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Subset observations (patients) from a [`Data`] object
#' using numeric or logical indexing.
#'
#' @param x (`Data`)\cr what to subset.
#' @param i (`integer` or `logical`)\cr indices or logical vector
#'   for subsetting observations.
#'
#' @return A [`Data`] object with the selected observations.
#'
#' @name subset-Data
#'
#' @aliases [,Data,numeric,missing,missing-method
#' @export
#'
setMethod(
  f = "[",
  signature = signature(
    x = "Data",
    i = "numeric",
    j = "missing",
    drop = "missing"
  ),
  definition = function(x, i) {
    Data(
      x = x@x[i],
      y = x@y[i],
      ID = x@ID[i],
      cohort = x@cohort[i],
      doseGrid = x@doseGrid,
      placebo = x@placebo,
      backfilled = x@backfilled[i],
      response = x@response[i]
    )
  }
)

#' @rdname subset-Data
setMethod(
  f = "[",
  signature = signature(
    x = "Data",
    i = "logical",
    j = "missing",
    drop = "missing"
  ),
  definition = function(x, i) {
    Data(
      x = x@x[i],
      y = x@y[i],
      ID = x@ID[i],
      cohort = x@cohort[i],
      doseGrid = x@doseGrid,
      placebo = x@placebo,
      backfilled = x@backfilled[i],
      response = x@response[i]
    )
  }
)

# plot ----

## Data ----

#' Plot Method for the [`Data`] Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`Data`] object.
#'
#' @param include_backfill (`flag`)\cr whether to include backfilled patients.
#' @param mark_backfill (`flag`)\cr whether to mark backfilled patients with empty shape.
#' @param mark_response (`flag`)\cr whether to mark patients with response with rectangle.
#' @param text_size_markings (`number`)\cr text size for the markings legend.
#' @param point_cex_markings (`number`)\cr point size multiplier for the markings legend.
#'
#' @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,
    include_backfill = TRUE,
    mark_backfill = FALSE,
    mark_response = FALSE,
    ...,
    text_size_markings = 9,
    point_cex_markings = 1.1
  ) {
    assert_flag(blind)
    assert_flag(legend)
    assert_flag(include_backfill)
    assert_flag(mark_backfill)
    assert_flag(mark_response)
    assert_number(text_size_markings, lower = 1)
    assert_number(point_cex_markings, lower = 0)

    if (!include_backfill) {
      x <- x[!x@backfilled]
    }

    p <- h_plot_data_dataordinal(
      x,
      blind,
      legend,
      mark_backfill = mark_backfill,
      ...
    )

    if (mark_backfill || mark_response) {
      df <- h_plot_data_df(
        x,
        blind = blind,
        response = x@response,
        backfilled = x@backfilled
      )
      if (mark_response) {
        p <- p +
          geom_point(
            data = df[!is.na(df$response) & df$response == 1, ],
            aes(
              x = patient,
              y = dose
            ),
            shape = 0,
            colour = "blue",
            size = 5
          )
      }

      # Create custom guide for markings
      marking_grobs <- list()
      grob_idx <- 1L

      if (mark_response) {
        response_point <- grid::pointsGrob(
          x = 0.05,
          y = 0.5,
          pch = 0,
          gp = grid::gpar(col = "blue", cex = point_cex_markings)
        )
        response_label <- grid::textGrob(
          "   Response",
          x = 0.25,
          y = 0.5,
          just = "left",
          gp = grid::gpar(fontsize = text_size_markings)
        )
        marking_grobs[[grob_idx]] <- grid::grobTree(
          response_point,
          response_label
        )
        grob_idx <- grob_idx + 1L
      }

      if (mark_backfill) {
        # Show filled vs hollow shapes to explain
        # backfill marking (which is done in h_plot_data_dataordinal)
        primary_point <- grid::pointsGrob(
          x = 0.05,
          y = 0.5,
          pch = 16, # filled circle
          gp = grid::gpar(col = "black", cex = point_cex_markings)
        )
        primary_label <- grid::textGrob(
          "   Escalation",
          x = 0.25,
          y = 0.5,
          just = "left",
          gp = grid::gpar(fontsize = text_size_markings)
        )
        marking_grobs[[grob_idx]] <- grid::grobTree(
          primary_point,
          primary_label
        )
        grob_idx <- grob_idx + 1L

        backfill_point <- grid::pointsGrob(
          x = 0.05,
          y = 0.5,
          pch = 1, # open circle
          gp = grid::gpar(col = "black", cex = point_cex_markings)
        )
        backfill_label <- grid::textGrob(
          "   Backfill",
          x = 0.25,
          y = 0.5,
          just = "left",
          gp = grid::gpar(fontsize = text_size_markings)
        )
        marking_grobs[[grob_idx]] <- grid::grobTree(
          backfill_point,
          backfill_label
        )
        grob_idx <- grob_idx + 1L
      }

      # Combine all marking grobs vertically
      if (length(marking_grobs) > 0) {
        heights <- grid::unit(rep(1, length(marking_grobs)), "cm")
        marking_grob <- do.call(
          gridExtra::arrangeGrob,
          c(marking_grobs, list(ncol = 1, heights = heights))
        )

        p <- p +
          guides(
            custom = guide_custom(
              grob = marking_grob,
              title = "Marking"
            )
          )
      }
    }
    p
  }
)

#' 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 response (`integer`)\cr the efficacy response vector
#'   (0/1 vector). May contain `NA`.
#' @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 backfill (`flag`)\cr whether the new patients being added
#'   are from a backfill cohort.
#' @param cohort (`int`)\cr if provided, the new patients will be assigned
#'   to this cohort index. If `NULL` (default), the cohort index will be
#'   determined based on the `new_cohort` parameter.
#' @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,
    response = rep(NA_integer_, length(y)),
    ID = length(object@ID) + seq_along(y),
    new_cohort = TRUE,
    check = TRUE,
    backfill = FALSE,
    cohort = NULL,
    ...
  ) {
    assert_numeric(x, min.len = 0, max.len = 1)
    assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE)
    assert_integerish(
      response,
      len = length(y),
      lower = 0,
      upper = 1,
      any.missing = TRUE
    )
    assert_integerish(ID, len = length(y), any.missing = FALSE)
    assert_disjunct(object@ID, ID)
    assert_flag(new_cohort)
    assert_flag(check)
    assert_flag(backfill)
    assert_int(cohort, lower = 1, null.ok = TRUE)

    # 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 response data.
    object@response <- c(object@response, response)

    # Add ID.
    object@ID <- c(object@ID, as.integer(ID))

    # Add cohort number.
    new_cohort_id <- if (!is.null(cohort)) {
      cohort
    } else 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

    # Add backfill information.
    object@backfilled <- c(object@backfilled, rep(backfill, n))

    # We might need to sort again when we supplied a cohort index.
    if (!is.null(cohort)) {
      ord <- order(object@cohort, object@ID)
      object@x <- object@x[ord]
      object@y <- object@y[ord]
      object@response <- object@response[ord]
      object@ID <- object@ID[ord]
      object@xLevel <- object@xLevel[ord]
      object@cohort <- object@cohort[ord]
      object@backfilled <- object@backfilled[ord]
    }

    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)
  }
)

## Data ----

#' Tidy Method for the [`Data`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`Data`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-Data
#' @rdname tidy
#' @export
#' @example examples/Data-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "Data"),
  definition = function(x, ...) {
    d <- callNextMethod()
    d %>%
      tibble::add_column(Response = x@response) %>%
      tibble::add_column(Backfilled = x@backfilled) %>%
      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
  }
)

# 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),
    ifelse(x@include_backfill, " ", " (excluding backfill 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
}

# 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 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))
        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)
  }
)

#' @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 [`NextBestEWOC`], [`NextBestMTD`], [`NextBestNCRM`],
#'   [`NextBestNCRMLoss`], [`NextBestThreePlusThree`], [`NextBestDualEndpoint`],
#'   [`NextBestMinDist`], [`NextBestInfTheory`], [`NextBestTD`],
#'   [`NextBestTDsamples`], [`NextBestMaxGain`], [`NextBestMaxGainSamples`],
#'   [`NextBestProbMTDLTE`], [`NextBestProbMTDMinDist`], [`NextBestOrdinal`].
#'
#' @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."
  ))
}

#' `NextBestEWOC`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestEWOC`] is the class implementing Escalation With Overdose Control
#' (EWOC). It recommends the highest possible dose subject to a probabilistic
#' constraint that the posterior probability of overdosing does not exceed
#' `max_overdose_prob`. Overdosing is defined as the model-based toxicity
#' probability lying inside the interval given by `overdose`.
#'
#' @slot target (`proportion`)\cr target toxicity probability to be
#'   achieved, below `overdose[1]`; only used for simulation reporting purposes.
#' @slot overdose (`numeric`)\cr the (exclusive) lower and (inclusive) upper boundaries of the
#'   toxicity probability interval considered an overdose region. The prototype
#'   uses `c(0.35, 1)` meaning probabilities > 0.35 are treated as overly toxic.
#' @slot max_overdose_prob (`proportion`)\cr maximum acceptable posterior
#'   probability that the next recommended dose is in the overdose interval.
#'
#' @seealso [`NextBest`], other next-best classes listed in its documentation.
#'
#' @aliases NextBestEWOC
#' @export
.NextBestEWOC <- setClass(
  Class = "NextBestEWOC",
  slots = c(
    target = "numeric",
    overdose = "numeric",
    max_overdose_prob = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  ),
  contains = "NextBest",
  validity = v_next_best_ewoc
)

## constructor ----

#' @rdname NextBestEWOC-class
#'
#' @param target (`proportion`)\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-NextBestEWOC.R
NextBestEWOC <- function(target, overdose, max_overdose_prob) {
  .NextBestEWOC(
    target = target,
    overdose = overdose,
    max_overdose_prob = max_overdose_prob
  )
}

## default constructor ----

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

# 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.
#' @slot include_backfill (`flag`)\cr whether to include backfill patients.
#'
#' @aliases StoppingPatientsNearDose
#' @export
#'
.StoppingPatientsNearDose <- setClass(
  Class = "StoppingPatientsNearDose",
  slots = c(
    nPatients = "integer",
    percentage = "numeric",
    include_backfill = "logical"
  ),
  prototype = prototype(
    nPatients = 10L,
    percentage = 50,
    include_backfill = TRUE
  ),
  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 include_backfill (`flag`)\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,
  include_backfill = TRUE,
  report_label = NA_character_
) {
  assert_count(nPatients, positive = TRUE)
  assert_number(percentage, lower = 0, upper = 100)
  assert_flag(include_backfill)

  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,
    include_backfill = include_backfill,
    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,
    include_backfill = TRUE,
    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)
}

# CohortSizeRandom ----

## class ----

#' `CohortSizeRandom`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`CohortSizeRandom`] is the class for random cohort sizes drawn from a
#' uniform distribution between `min_size` and `max_size` (inclusive).
#'
#' @slot min_size (`integer`)\cr minimum cohort size.
#' @slot max_size (`integer`)\cr maximum cohort size.
#'
#' @aliases CohortSizeRandom
#' @export
#'
.CohortSizeRandom <- setClass(
  Class = "CohortSizeRandom",
  slots = c(min_size = "integer", max_size = "integer"),
  prototype = prototype(min_size = 1L, max_size = 3L),
  contains = "CohortSize",
  validity = v_cohort_size_random
)

## constructor ----

#' @rdname CohortSizeRandom-class
#'
#' @param min_size (`integer`)\cr see slot definition.
#' @param max_size (`integer`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeRandom.R
#'
CohortSizeRandom <- function(min_size, max_size) {
  assert_integerish(min_size, lower = 1, len = 1)
  assert_integerish(max_size, lower = min_size + 1, len = 1)
  .CohortSizeRandom(
    min_size = as.integer(min_size),
    max_size = as.integer(max_size)
  )
}

## default constructor ----

#' @rdname CohortSizeRandom-class
#' @note Typically, end users will not use the `.DefaultCohortSizeRandom()` function.
#' @export
.DefaultCohortSizeRandom <- function() {
  CohortSizeRandom(min_size = 1L, max_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
  )
}

#' 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()
}

##' @include helpers.R
##' @include Model-class.R
NULL

# Helper functions ----

#' Get Starting Values for Quantiles Optimization
#'
#' @param parstart (`numeric` or `NULL`)\cr starting parameter values.
#' @param median (`numeric`)\cr median values.
#' @param dosegrid (`numeric`)\cr dose grid.
#' @param refDose (`number`)\cr reference dose.
#' @param logNormal (`flag`)\cr use log-normal prior?
#'
#' @return Numeric vector of starting values.
#' @keywords internal
h_get_quantiles_start_values <- function(
  parstart,
  median,
  dosegrid,
  refDose,
  logNormal
) {
  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))))

    c(
      meanAlpha = unname(startAlphaBeta[1]),
      meanBeta = unname(
        if (logNormal) log(startAlphaBeta[2]) else startAlphaBeta[2]
      ),
      sdAlpha = 1,
      sdBeta = 1,
      correlation = 0
    )
  } else {
    parstart
  }
}

#' Target Function for Quantiles Optimization
#'
#' @param dosegrid (`numeric`)\cr dose grid.
#' @param refDose (`number`)\cr reference dose.
#' @param lower (`numeric`)\cr lower quantiles.
#' @param median (`numeric`)\cr median quantiles.
#' @param upper (`numeric`)\cr upper quantiles.
#' @param level (`number`)\cr credible level.
#' @param logNormal (`flag`)\cr use log-normal prior?
#' @param seed (`count`)\cr random seed.
#'
#' @return Function that computes target value for optimization.
#' @keywords internal
h_quantiles_target_function <- function(
  dosegrid,
  refDose,
  lower,
  median,
  upper,
  level,
  logNormal,
  seed
) {
  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]
    }

    # Compute resulting quantiles
    quants <- matrix(
      nrow = length(dosegrid),
      ncol = 3L
    )
    colnames(quants) <- c("lower", "median", "upper")

    # Process each dose
    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)
      )
    }

    # Compute the target value
    ret <- max(abs(quants - c(lower, median, upper)))
    structure(ret, mean = mean, cov = cov, quantiles = quants)
  }
}

# Quantiles2LogisticNormal ----

#' Convert Prior Quantiles to Logistic (Log) Normal Model
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function uses generalized simulated annealing to optimize
#' a [`LogisticNormal`] model to be as close as possible
#' to the given prior quantiles.
#'
#' @param dosegrid (`numeric`)\cr the dose grid.
#' @param refDose (`number`)\cr the reference dose.
#' @param lower (`numeric`)\cr the lower quantiles.
#' @param median (`numeric`)\cr the medians.
#' @param upper (`numeric`)\cr the upper quantiles.
#' @param level (`number`)\cr the credible level of the (lower, upper) intervals.
#'   Default is 0.95.
#' @param logNormal (`flag`)\cr use the log-normal prior? If `FALSE` (default),
#'   the normal prior for the logistic regression coefficients is used.
#' @param parstart (`numeric` or `NULL`)\cr starting values for the parameters.
#'   By default, these are determined from the medians supplied.
#' @param parlower (`numeric`)\cr lower bounds on the parameters (intercept alpha
#'   and the slope beta, the corresponding standard deviations and the correlation).
#' @param parupper (`numeric`)\cr upper bounds on the parameters.
#' @param seed (`count`)\cr seed for random number generation.
#' @param verbose (`flag`)\cr should the function be verbose?
#' @param control (`list`)\cr additional options for the optimisation routine,
#'   see [GenSA::GenSA()] for more details.
#'
#' @return A list with the best approximating `model`
#'   ([`LogisticNormal`] or [`LogisticLogNormal`]), the resulting `quantiles`,
#'   the `required` quantiles and the `distance` to the required quantiles,
#'   as well as the final `parameters` (which could be used for running the
#'   algorithm a second time).
#'
#' @importFrom GenSA GenSA
#' @importFrom mvtnorm rmvnorm
#' @export
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
  )
) {
  # Argument validation
  assert_numeric(
    dosegrid,
    min.len = 1,
    any.missing = FALSE,
    sorted = TRUE,
    unique = TRUE
  )
  assert_number(refDose, finite = TRUE)
  assert_numeric(lower, len = length(dosegrid), any.missing = FALSE)
  assert_numeric(
    median,
    len = length(dosegrid),
    any.missing = FALSE,
    sorted = TRUE
  )
  assert_numeric(upper, len = length(dosegrid), any.missing = FALSE)
  assert_probability(level, bounds_closed = FALSE)
  assert_flag(logNormal)
  assert_numeric(parstart, len = 5, null.ok = TRUE)
  assert_numeric(parlower, len = 5, any.missing = FALSE)
  assert_numeric(parupper, len = 5, any.missing = FALSE)
  assert_count(seed, positive = TRUE)
  assert_flag(verbose)
  assert_list(control)

  # Additional validation
  assert_true(all(lower < median))
  assert_true(all(median < upper))
  assert_true(all(parlower < parupper))
  if (!is.null(parstart)) {
    assert_true(all(parlower < parstart))
    assert_true(all(parstart < parupper))
  }

  nDoses <- length(dosegrid)
  control$verbose <- verbose

  startValues <- h_get_quantiles_start_values(
    parstart = parstart,
    median = median,
    dosegrid = dosegrid,
    refDose = refDose,
    logNormal = logNormal
  )

  target <- h_quantiles_target_function(
    dosegrid = dosegrid,
    refDose = refDose,
    lower = lower,
    median = median,
    upper = upper,
    level = level,
    logNormal = logNormal,
    seed = seed
  )

  set.seed(seed)
  # Optimize the target function
  genSAres <- GenSA::GenSA(
    par = startValues,
    fn = target,
    lower = parlower,
    upper = parupper,
    control = control
  )
  distance <- genSAres$value
  pars <- genSAres$par
  targetRes <- target(pars)

  # Construct the model
  model <- 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
    )
  }

  list(
    model = model,
    parameters = pars,
    quantiles = attr(targetRes, "quantiles"),
    required = cbind(lower, median, upper),
    distance = distance
  )
}

#' Helper for Minimal Informative Unimodal Beta Distribution
#'
#' As defined in \insertCite{NeuenschwanderBransonGsponer2008;textual}{crmPack}, 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
#' @references
#'   \insertAllCited{}
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)
    )
  }
}

# MinimalInformative ----

#' Construct a Minimally Informative Prior
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function constructs a minimally informative prior, which is captured in
#' a [`LogisticNormal`] (or [`LogisticLogNormal`]) object.
#'
#' Based on the proposal by \insertCite{NeuenschwanderBransonGsponer2008;textual}{crmPack},
#' 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 `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,
#' `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 `probmin` and `probmax`, respectively.
#' Subsequently, for all doses supplied in the
#' `dosegrid` argument, beta distributions are set up from the assumption
#' that the prior medians are linear in log-dose on the logit scale, and
#' [Quantiles2LogisticNormal()] is used to transform the resulting
#' quantiles into an approximating [`LogisticNormal`] (or
#' [`LogisticLogNormal`]) model. Note that the reference dose
#' is not required for these computations.
#'
#' @param dosegrid (`numeric`)\cr the dose grid.
#' @param refDose (`number`)\cr the reference dose.
#' @param threshmin (`number`)\cr any toxicity probability above this threshold
#'   would be very unlikely (see `probmin`) at the minimum dose.
#' @param threshmax (`number`)\cr any toxicity probability below this threshold
#'   would be very unlikely (see `probmax`) at the maximum dose.
#' @param probmin (`number`)\cr the prior probability of exceeding `threshmin`
#'   at the minimum dose.
#' @param probmax (`number`)\cr the prior probability of being below `threshmax`
#'   at the maximum dose.
#' @param ... additional arguments for computations, see
#'   [Quantiles2LogisticNormal()], e.g. `refDose` and
#'   `logNormal=TRUE` to obtain a minimal informative log normal prior.
#'
#' @return See [Quantiles2LogisticNormal()].
#'
#' @example examples/MinimalInformative.R
#' @export
#' @references
#'   \insertAllCited{}
MinimalInformative <- function(
  dosegrid,
  refDose,
  threshmin = 0.2,
  threshmax = 0.3,
  probmin = 0.05,
  probmax = 0.05,
  ...
) {
  # Argument validation
  assert_numeric(
    dosegrid,
    min.len = 1,
    any.missing = FALSE,
    sorted = TRUE,
    unique = TRUE
  )
  assert_number(refDose, finite = TRUE)
  assert_probability(threshmin, bounds_closed = FALSE)
  assert_probability(threshmax, bounds_closed = FALSE)
  assert_probability(probmin, bounds_closed = FALSE)
  assert_probability(probmax, bounds_closed = FALSE)

  nDoses <- length(dosegrid)
  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))

  # 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))

  # Calculate 95% credible interval bounds (lower and upper) for all doses
  lower <- upper <- dosegrid
  for (i in seq_along(dosegrid)) {
    # Get minimal informative 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))
  }

  # Transform quantiles to LogisticNormal model
  Quantiles2LogisticNormal(
    dosegrid = dosegrid,
    refDose = refDose,
    lower = lower,
    median = medianDosegrid,
    upper = upper,
    level = 0.95,
    ...
  )
}

# nolint end

#' 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) {
    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$check(
    test_logical(object@backfilled, len = object@nObs, any.missing = FALSE),
    "backfilled must be of type logical and length nObs and not contain missings"
  )
  v$check(
    test_integer(
      object@response,
      len = object@nObs,
      lower = 0,
      upper = 1,
      any.missing = TRUE
    ),
    "response must be of type integer, take values 0 or 1 or NA, and have length nObs"
  )

  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()
}

# 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
}

#' 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(
    isTRUE(all.equal(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()
}

# OpeningMinDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print OpeningMinDose
knit_print.OpeningMinDose <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  rv <- paste0(
    "If the backfill cohort's dose is ",
    x@min_dose,
    " or higher.\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# OpeningMinCohorts ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.OpeningMinDose
#' @rdname knit_print
#' @export
#' @method knit_print OpeningMinCohorts
knit_print.OpeningMinCohorts <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  rv <- paste0(
    "If ",
    x@min_cohorts,
    " or more cohorts have been treated in total.\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# OpeningNone ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.OpeningMinDose
#' @rdname knit_print
#' @export
#' @method knit_print OpeningNone
knit_print.OpeningNone <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  rv <- paste0(
    "No backfill cohorts at all will be opened.\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# OpeningMinResponses ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.OpeningMinDose
#' @rdname knit_print
#' @export
#' @method knit_print OpeningMinResponses
knit_print.OpeningMinResponses <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  doses_text <- ifelse(
    x@include_lower_doses,
    "at this dose or lower",
    "at this dose"
  )

  rv <- paste0(
    "If ",
    x@min_responses,
    " or more responses have been observed ",
    doses_text,
    ".\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# OpeningList ----

#' @description `r lifecycle::badge("experimental")`
#' @param preamble (`character`)\cr the text that introduces the list of rules.
#' @param indent (`integer`)\cr the indent level of the current opening rule
#'   list. Spaces with length `indent * 4` will be prepended to the beginning of
#'   the rendered opening rule list.
#' @inheritParams knit_print.OpeningMinDose
#' @rdname knit_print
#' @export
#' @method knit_print OpeningList
knit_print.OpeningList <- 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@open_list)),
      `1` = "rule applies",
      "rules apply"
    )
    preamble <- paste0(
      "The following opening ",
      case_string,
      ":\n"
    )
  } else {
    assert_string(preamble)
  }

  rules_list <- paste0(
    lapply(
      x@open_list,
      function(z, indent) {
        paste0(
          strrep(" ", indent * 4),
          "-  ",
          knit_print(z, asis = FALSE, indent = indent + 1L, ...)
        )
      },
      indent = indent
    ),
    collapse = "\n"
  )
  rv <- paste0(
    preamble,
    "\n",
    rules_list,
    "\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# OpeningAll ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.OpeningList
#' @rdname knit_print
#' @export
#' @method knit_print OpeningAll
knit_print.OpeningAll <- function(
  x,
  ...,
  preamble,
  asis = TRUE
) {
  if (missing(preamble)) {
    case_string <- switch(
      as.character(length(x@open_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],
      "satisfied:\n"
    )
  }
  knit_print.OpeningList(x, ..., preamble = preamble, asis = asis)
}

# OpeningAny ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.OpeningList
#' @rdname knit_print
#' @export
#' @method knit_print OpeningAny
knit_print.OpeningAny <- function(
  x,
  ...,
  preamble,
  asis = TRUE
) {
  if (missing(preamble)) {
    case_string <- switch(
      as.character(length(x@open_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],
      "satisfied:\n"
    )
  }
  knit_print.OpeningList(x, ..., preamble = preamble, asis = asis)
}

#' 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
}

# 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 `trial_duration` 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@trial_duration), nSims),
    "trial_duration vector has to have same length as data"
  )

  v$result()
}

# 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 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))), # nolint
      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")

  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"))) {
    value
  } else {
    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 (`number`)\cr defines the true probability for a DLT at the dose.
#' @param prob_placebo (`number`)\cr defines the true probability for a DLT at a placebo condition.
#' @param prob_response (`number`)\cr defines the true probability for a response at the dose.
#' @param prob_response_placebo (`number`)\cr defines the true probability for a response 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 = 0,
  prob_response = 0,
  prob_response_placebo = 0,
  cohort_size,
  cohort_size_placebo = 0,
  dose_grid,
  first_separate
) {
  assert_class(data, "Data")
  assert_number(dose)
  assert_number(prob, lower = 0, upper = 1)
  assert_number(prob_placebo, lower = 0, upper = 1, null.ok = TRUE)
  assert_number(prob_response, lower = 0, upper = 1)
  assert_number(prob_response_placebo, lower = 0, upper = 1, null.ok = TRUE)
  assert_number(cohort_size)
  assert_number(cohort_size_placebo, null.ok = TRUE)
  assert_flag(first_separate)

  if (first_separate && cohort_size > 1) {
    dlts <- rbinom(n = 1, size = 1, prob = prob)
    response <- rbinom(n = 1, size = 1, prob = prob_response)
    if ((data@placebo) && cohort_size_placebo > 0) {
      dlts_placebo <- rbinom(n = 1, size = 1, prob = prob_placebo)
      response_placebo <- rbinom(
        n = 1,
        size = 1,
        prob = prob_response_placebo
      )
    }
    if (dlts == 0) {
      dlts <- c(dlts, rbinom(n = cohort_size - 1L, size = 1, prob = prob))
      response <- c(
        response,
        rbinom(n = cohort_size - 1L, size = 1, prob = prob_response)
      )
      if ((data@placebo) && cohort_size_placebo > 0) {
        dlts_placebo <- c(
          dlts_placebo,
          rbinom(
            n = cohort_size_placebo - 1L,
            size = 1,
            prob = prob_placebo
          )
        )
        response_placebo <- c(
          response_placebo,
          rbinom(
            n = cohort_size_placebo - 1L,
            size = 1,
            prob = prob_response_placebo
          )
        )
      }
    }
  } else {
    dlts <- rbinom(n = cohort_size, size = 1, prob = prob)
    response <- rbinom(n = cohort_size, size = 1, prob = prob_response)
    if ((data@placebo) && cohort_size_placebo > 0) {
      dlts_placebo <- rbinom(
        n = cohort_size_placebo,
        size = 1,
        prob = prob_placebo
      )
      response_placebo <- rbinom(
        n = cohort_size_placebo,
        size = 1,
        prob = prob_response_placebo
      )
    }
  }

  if ((data@placebo) && cohort_size_placebo > 0) {
    data <- update(
      object = data,
      x = data@doseGrid[1],
      y = dlts_placebo,
      response = response_placebo,
      check = FALSE
    )

    ## update the data with active dose
    data <- update(
      object = data,
      x = dose,
      y = dlts,
      response = response,
      new_cohort = FALSE
    )
  } else {
    ## update the data with this cohort
    data <- update(
      object = data,
      x = dose,
      y = dlts,
      response = response
    )
  }
  data
}

#' Helper Function to Update Backfill Queue
#'
#' This function manages the backfill cohort queue by determining which
#' previous cohorts are open or closed for backfill enrollment.
#'
#' @param backfill_cohorts (`list`)\cr current queue of backfill cohorts.
#' @param data (`Data`)\cr current trial data.
#' @param dose (`number`)\cr current dose being evaluated.
#' @param backfill (`Backfill`)\cr with opening rules and cohort size.
#'
#' @return Updated `backfill_cohorts` list.
#'
#' @keywords internal
h_update_backfill_queue <- function(backfill_cohorts, data, dose, backfill) {
  # Loop over all previous cohorts and check which are open for backfill.
  for (cohort in seq_len(max(data@cohort) - 1)) {
    open_for_backfill <- openCohort(
      opening = backfill@opening,
      cohort = cohort,
      data = data,
      dose = dose
    )

    # Note: we index the cohorts in the queue by their cohort number
    # coerced as a string.
    cohort_string <- as.character(cohort)
    is_in_queue <- !is.null(backfill_cohorts[[cohort_string]])

    if (is_in_queue) {
      # Make sure to not reopen full backfill cohorts.
      is_full <- backfill_cohorts[[cohort_string]]$current_size ==
        backfill_cohorts[[cohort_string]]$max_size
      # Mark this cohort accordingly in the backfill queue.
      backfill_cohorts[[cohort_string]]$open <- !is_full &&
        open_for_backfill
    } else if (open_for_backfill) {
      # Add this new cohort to the backfill queue.
      backfill_dose <- h_get_dose_for_cohort(data, cohort)
      backfill_cohort_size <- size(
        object = backfill@cohort_size,
        dose = backfill_dose,
        cohort = cohort,
        data = data
      )
      backfill_cohorts[[as.character(cohort)]] <- list(
        dose = backfill_dose,
        cohort = cohort,
        current_size = 0L,
        max_size = backfill_cohort_size,
        open = TRUE # Mark as open.
      )
    }
  }

  backfill_cohorts
}

#' Helper Function to Enroll Backfill Patients
#'
#' This function executes backfill enrollment according to the priority rule,
#' updating the data object, backfill cohort queue, and patient counter.
#'
#' @param backfill_cohorts (`list`)\cr current queue of backfill cohorts.
#' @param data (`Data`)\cr current trial data.
#' @param backfill (`Backfill`)\cr with priority and recruitment rules.
#' @param cohort_size (`count`)\cr size of the active cohort.
#' @param backfill_patients (`count`)\cr number of enrolled backfill patients.
#' @param current_args (`data.frame`)\cr arguments for the truth function.
#' @param truth (`function`)\cr defining true DLT probability.
#' @param truthResponse (`function`)\cr defining true response probability.
#'
#' @return List with updated `data`, `backfill_cohorts`, and
#'   `backfill_patients`.
#'
#' @keywords internal
h_enroll_backfill_patients <- function(
  backfill_cohorts,
  data,
  backfill,
  cohort_size,
  backfill_patients,
  current_args,
  truth,
  truthResponse
) {
  # Number of backfill patients we can enroll in this cycle.
  max_recruits <- maxRecruits(
    backfill@recruitment,
    active_cohort_size = cohort_size
  )
  backfill_left <- backfill@max_size - backfill_patients
  max_recruits <- min(max_recruits, backfill_left)

  # Enroll backfill cohorts.
  if (
    length(backfill_cohorts) > 0 &&
      max_recruits > 0
  ) {
    backfill_doses <- sapply(
      backfill_cohorts,
      "[[",
      "dose"
    )
    # Order backfill cohorts according to priority rule.
    order_indices <- switch(
      backfill@priority,
      highest = order(-backfill_doses),
      lowest = order(backfill_doses),
      random = sample.int(
        n = length(backfill_cohorts),
        size = length(backfill_cohorts)
      )
    )
    for (i_bc in order_indices) {
      bc <- backfill_cohorts[[i_bc]]
      if (!bc$open) {
        next
      }
      enroll_size <- min(bc$max_size - bc$current_size, max_recruits)
      if (enroll_size == 0) {
        next
      }
      bc_dlts <- rbinom(
        n = enroll_size,
        size = 1,
        prob = h_this_truth(bc$dose, current_args, truth)
      )
      bc_response <- rbinom(
        n = enroll_size,
        size = 1,
        prob = truthResponse(bc$dose)
      )

      data <- update(
        object = data,
        x = bc$dose,
        y = bc_dlts,
        cohort = bc$cohort,
        response = bc_response,
        backfill = TRUE
      )

      # Record number of patients in the backfill cohort and overall.
      backfill_cohorts[[i_bc]]$current_size <-
        backfill_cohorts[[i_bc]]$current_size + enroll_size
      max_recruits <- max_recruits - enroll_size
      backfill_patients <- backfill_patients + enroll_size

      # Close this cohort if it's fully enrolled.
      if (
        backfill_cohorts[[i_bc]]$current_size ==
          backfill_cohorts[[i_bc]]$max_size
      ) {
        backfill_cohorts[[i_bc]]$open <- FALSE
      }

      # Stop enrolling backfill in this cycle if we reached the limit.
      if (max_recruits == 0) {
        break
      }
    }
  }

  list(
    data = data,
    backfill_cohorts = backfill_cohorts,
    backfill_patients = backfill_patients
  )
}

#' 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),
  mark_backfill = FALSE,
  ...
) {
  assert_flag(blind)
  assert_flag(legend)
  assert_flag(mark_backfill)
  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, ...)

  # Determine shape key per-point, using open shapes for backfill patients.
  if (mark_backfill) {
    if (!("backfilled" %in% names(df))) {
      # Try to obtain backfilled information from the object if available.
      df$backfilled <- if (
        methods::is(x, "Data") && length(x@backfilled) == nrow(df)
      ) {
        x@backfilled
      } else {
        rep(FALSE, nrow(df))
      }
    }
    df$shape_key <- ifelse(
      df$backfilled,
      paste0(df$toxicity, "_bf"),
      df$toxicity
    )
  } else {
    df$shape_key <- df$toxicity
  }

  # Build shape scale values, adding open-shape variants for backfill when needed.
  shape_values <- tox_shapes
  if (mark_backfill) {
    convert_to_open <- function(s) {
      # Map common filled shapes to their open counterparts.
      switch(
        as.character(s),
        "16" = 1L, # filled circle -> open circle
        "17" = 2L, # filled triangle -> open triangle
        "15" = 0L, # filled square -> open square
        "18" = 5L, # filled diamond -> open diamond
        "19" = 1L, # large filled circle -> open circle
        # If already open or unknown, keep as-is
        as.integer(s)
      )
    }
    bf_shapes <- vapply(unname(tox_shapes), convert_to_open, integer(1))
    names(bf_shapes) <- paste0(names(tox_shapes), "_bf")
    shape_values <- c(shape_values, bf_shapes)
  }

  p <- ggplot(df, aes(x = .data$patient, y = .data$dose)) +
    geom_point(
      aes(shape = .data$shape_key, colour = .data$toxicity),
      size = 3
    ) +
    scale_colour_manual(
      name = "Toxicity",
      values = tox_labels,
      breaks = names(tox_labels),
      limits = names(tox_labels),
      drop = FALSE,
      guide = guide_legend(
        reverse = TRUE,
        override.aes = list(
          shape = unname(rev(tox_shapes[names(tox_labels)]))
        )
      )
    ) +
    scale_shape_manual(
      values = shape_values,
      guide = "none"
    ) +
    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 = .data$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
  )
}

#' Set Default Values for kable Parameters
#'
#' Sets default values for `col.names` and `caption` if not already provided
#' by the user in the parameter list.
#'
#' @param param (`list`)\cr The list of `...` parameters passed to `knit_print`
#' @param col_names (`character`)\cr Default column names for the table
#' @param caption (`character`)\cr Default caption for the table
#' @return The updated parameter list with defaults applied
#' @keywords internal
h_kable_param_default <- function(param, col_names = NULL, caption = NULL) {
  assert_list(param)
  if (!is.null(col_names)) {
    assert_character(col_names, any.missing = FALSE)
    if (!("col.names" %in% names(param))) {
      param[["col.names"]] <- col_names
    }
  }
  if (!is.null(caption)) {
    assert_character(caption, len = 1, any.missing = FALSE)
    if (!("caption" %in% names(param))) {
      param[["caption"]] <- caption
    }
  }
  param
}

#' 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"))
  )
}

# 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_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 <- h_kable_param_default(
    list(...),
    col_names = c("Min", "Max", "Increment"),
    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 <- h_kable_param_default(
    list(...),
    col_names = c("Min", "Max", "Increment"),
    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 <- h_kable_param_default(
    list(...),
    col_names = c("Lower", "Upper", "Increment"),
    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)
  tox_label <- h_prepare_labels(tox_label)

  param <- h_kable_param_default(
    list(...),
    col_names = c("Min", "Max", "Increment"),
    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
}

# 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
}

#' 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))]
  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)
  })

  list(param_names, averages)
}

#' @include Backfill-class.R
#' @include helpers.R
NULL

# openCohort ----

## generic ----

#' Open / recruit backfill patients into a cohort?
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @param opening (`Opening`)\cr opening rule to be applied.
#' @param cohort (`int`)\cr backfill cohort index.
#' @param data (`Data`)\cr current trial data.
#' @param dose (`numeric`)\cr the recommended next best dose.
#' @param ... further arguments (not used).
#'
#' @return `TRUE` if this backfill cohort can be opened / recruited into,
#' `FALSE` otherwise.
setGeneric(
  name = "openCohort",
  def = function(opening, cohort, data, dose, ...) {
    # For any opening rule, if the dose of the cohort to be opened
    # is higher than or equal to the recommended dose, do not open it.
    cohort_dose <- h_get_dose_for_cohort(data, cohort)
    if (is.na(cohort_dose) || cohort_dose >= dose) {
      return(FALSE)
    }
    standardGeneric("openCohort")
  },
  valueClass = "logical"
)

## OpeningMinDose ----

#' @describeIn openCohort method for `OpeningMinDose` class.
#'
#' @aliases openCohort-OpeningMinDose
#'
#' @export
#' @example examples/Backfill-method-openCohort-OpeningMinDose.R
setMethod(
  f = "openCohort",
  signature = c(opening = "OpeningMinDose"),
  definition = function(opening, cohort, data, dose, ...) {
    cohort_dose <- h_get_dose_for_cohort(data, cohort)
    (!is.na(cohort_dose) &&
      cohort_dose >= opening@min_dose)
  }
)

## OpeningMinCohorts ----

#' @describeIn openCohort method for `OpeningMinCohorts` class.
#'
#' @aliases openCohort-OpeningMinCohorts
#'
#' @export
#' @example examples/Backfill-method-openCohort-OpeningMinCohorts.R
setMethod(
  f = "openCohort",
  signature = c(opening = "OpeningMinCohorts"),
  definition = function(opening, cohort, data, dose, ...) {
    n_cohorts <- max(data@cohort)
    n_cohorts >= opening@min_cohorts
  }
)

## OpeningNone ----

#' @describeIn openCohort method for `OpeningNone` class, which never opens a cohort, i.e.
#'   the trial design will not use backfilling.
#'
#' @aliases openCohort-OpeningNone
#'
#' @export
#' @example examples/Backfill-method-openCohort-OpeningNone.R
setMethod(
  f = "openCohort",
  signature = c(opening = "OpeningNone"),
  definition = function(opening, cohort, data, dose, ...) {
    FALSE
  }
)

## OpeningMinResponses ----

#' @describeIn openCohort method for `OpeningMinResponses` class.
#'
#' @aliases openCohort-OpeningMinResponses
#'
#' @export
#' @example examples/Backfill-method-openCohort-OpeningMinResponses.R
setMethod(
  f = "openCohort",
  signature = c(opening = "OpeningMinResponses"),
  definition = function(opening, cohort, data, dose, ...) {
    cohort_dose <- h_get_dose_for_cohort(data, cohort)

    # Count responses based on include_lower_doses flag
    if (opening@include_lower_doses) {
      # Count responses at cohort_dose and all lower doses
      response_count <- sum(data@response[data@x <= cohort_dose], na.rm = TRUE)
    } else {
      # Count responses only at cohort_dose
      response_count <- sum(data@response[data@x == cohort_dose], na.rm = TRUE)
    }

    response_count >= opening@min_responses
  }
)

## OpeningList ----

#' @describeIn openCohort method for `OpeningList` class.
#'
#' @aliases openCohort-OpeningList
#'
#' @param summary_fun (`function`)\cr to apply to the list of
#'   results (e.g., `all` or `any`).
#'   Only used for `OpeningList` and its subclasses.
#'
setMethod(
  f = "openCohort",
  signature = c(opening = "OpeningList"),
  definition = function(opening, cohort, data, dose, summary_fun, ...) {
    list_results <- vapply(
      opening@open_list,
      FUN = function(op) openCohort(op, cohort, data, dose, ...),
      FUN.VALUE = logical(1)
    )
    summary_fun(list_results)
  }
)

## OpeningAll ----

#' @describeIn openCohort method for `OpeningAll` class.
#'   Returns `TRUE` if ALL opening criteria are satisfied.
#'
#' @aliases openCohort-OpeningAll
#'
#' @export
#' @example examples/Backfill-method-openCohort-OpeningAll.R
setMethod(
  f = "openCohort",
  signature = c(opening = "OpeningAll"),
  definition = function(opening, cohort, data, dose, ...) {
    callNextMethod(opening, cohort, data, dose, summary_fun = all, ...)
  }
)

## OpeningAny ----

#' @describeIn openCohort method for `OpeningAny` class.
#'   Returns `TRUE` if ANY opening criteria are satisfied.
#'
#' @aliases openCohort-OpeningAny
#'
#' @export
#' @example examples/Backfill-method-openCohort-OpeningAny.R
setMethod(
  f = "openCohort",
  signature = c(opening = "OpeningAny"),
  definition = function(opening, cohort, data, dose, ...) {
    callNextMethod(opening, cohort, data, dose, summary_fun = any, ...)
  }
)

## & operator ----

#' Logical AND Operator for Opening Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Combines two [`Opening`] objects with AND logic using the `&` operator.
#' This creates an [`OpeningAll`] object.
#'
#' @param e1 (`Opening`)
#'   the first opening object.
#' @param e2 (`Opening`)
#'   the second opening object.
#'
#' @return An [`OpeningAll`] object combining `e1` and `e2`.
#'
#' @seealso [`OpeningAll`] for more details.
#'
#' @export
#' @name and,Opening,Opening-method
#' @aliases &,Opening,Opening-method
setMethod(
  f = "&",
  signature = c(e1 = "Opening", e2 = "Opening"),
  definition = function(e1, e2) {
    .OpeningAll(open_list = list(e1, e2))
  }
)

## | operator ----

#' Logical OR Operator for Opening Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Combines two [`Opening`] objects with OR logic using the `|` operator.
#' This creates an [`OpeningAny`] object.
#'
#' @param e1 (`Opening`)
#'   the first opening object.
#' @param e2 (`Opening`)
#'   the second opening object.
#'
#' @return An [`OpeningAny`] object combining `e1` and `e2`.
#'
#' @seealso [`OpeningAny`] for more details.
#'
#' @export
#' @name or,Opening,Opening-method
#' @aliases |,Opening,Opening-method
setMethod(
  f = "|",
  signature = c(e1 = "Opening", e2 = "Opening"),
  definition = function(e1, e2) {
    .OpeningAny(open_list = list(e1, e2))
  }
)

# maxRecruits ----

## generic ----

#' Calculate Maximum Number of Backfill Patients
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Calculates the maximum number of backfill patients that can be recruited
#' based on the recruitment rule and the active cohort size.
#'
#' @param object (`Recruitment`)\cr the recruitment rule.
#' @param active_cohort_size (`integer`)\cr the current size of the active
#'   dose escalation cohort.
#' @param ... further arguments (not used).
#'
#' @return The maximum number of backfill patients as an `integer`.
#'
#' @seealso [`Recruitment`], [`RecruitmentUnlimited`], [`RecruitmentRatio`].
#'
setGeneric(
  name = "maxRecruits",
  def = function(object, active_cohort_size, ...) {
    standardGeneric("maxRecruits")
  },
  valueClass = "integer"
)

## RecruitmentUnlimited ----

#' @describeIn maxRecruits method for `RecruitmentUnlimited` class.
#'   Returns a very large number (practically unlimited).
#'
#' @aliases maxRecruits-RecruitmentUnlimited
#'
#' @export
#' @example examples/Backfill-method-maxRecruits-RecruitmentUnlimited.R
setMethod(
  f = "maxRecruits",
  signature = c(object = "RecruitmentUnlimited"),
  definition = function(object, active_cohort_size, ...) {
    1e6L # Practically unlimited.
  }
)

## RecruitmentRatio ----

#' @describeIn maxRecruits method for `RecruitmentRatio` class.
#'   Returns `ceiling(ratio * active_cohort_size)`.
#'
#' @aliases maxRecruits-RecruitmentRatio
#'
#' @export
#' @example examples/Backfill-method-maxRecruits-RecruitmentRatio.R
setMethod(
  f = "maxRecruits",
  signature = c(object = "RecruitmentRatio"),
  definition = function(object, active_cohort_size, ...) {
    ratio <- object@ratio
    max_recruits <- as.integer(ceiling(ratio * active_cohort_size))
    max_recruits
  }
)

#' 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
}

# Opening ----

#' Internal Helper Functions for Validation of [`Opening`] Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' These functions are only used internally to validate the format of an input
#' [`Opening`] or inherited classes and therefore not exported.
#'
#' @name v_opening
#' @param object (`Opening`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_opening validates that the [`OpeningMinDose`] object
#'   contains valid `min_dose` slot.
v_opening_min_dose <- function(object) {
  v <- Validate()
  v$check(
    test_number(object@min_dose, lower = 0),
    "min_dose needs to be a non-negative numeric scalar"
  )
  v$result()
}
#' @describeIn v_opening validates that the [`OpeningMinCohorts`] object
#'   contains valid `min_cohorts` slot.
v_opening_min_cohorts <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@min_cohorts, lower = 1),
    "min_cohorts needs to be a positive integer scalar"
  )
  v$result()
}

#' @describeIn v_opening validates that the [`OpeningMinResponses`] object
#'   contains valid `min_responses` and `include_lower_doses` slots.
v_opening_min_responses <- function(object) {
  v <- Validate()
  v$check(
    test_count(object@min_responses, positive = TRUE),
    "min_responses needs to be a positive integer scalar"
  )
  v$check(
    test_flag(object@include_lower_doses),
    "include_lower_doses needs to be a logical flag"
  )
  v$result()
}

# Recruitment ----

#' Internal Helper Functions for Validation of [`Recruitment`] Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' These functions are only used internally to validate the format of an input
#' [`Recruitment`] or inherited classes and therefore not exported.
#'
#' @name v_recruitment
#' @param object (`Recruitment`)
#'   object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_recruitment validates that the [`RecruitmentRatio`] object
#'   contains valid `ratio` slot.
v_recruitment_ratio <- function(object) {
  v <- Validate()
  v$check(
    test_number(object@ratio, lower = 0),
    "ratio needs to be a non-negative numeric scalar"
  )
  v$result()
}

# Backfill ----

#' Internal Helper Functions for Validation of [`Backfill`] Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' These functions are only used internally to validate the format of an input
#' [`Backfill`] object and therefore not exported.
#'
#' @name v_backfill
#' @param object (`Backfill`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_backfill validates that the [`Backfill`] object
#'   contains valid slots.
v_backfill <- function(object) {
  v <- Validate()
  v$check(
    test_count(object@max_size, positive = TRUE),
    "max_size needs to be a positive integer scalar"
  )
  v$check(
    test_choice(object@priority, c("highest", "lowest", "random")),
    "priority needs to be one of 'highest', 'lowest', or 'random'"
  )
  v$result()
}

# 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()
}

# RecruitmentUnlimited ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print RecruitmentUnlimited
knit_print.RecruitmentUnlimited <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  rv <- paste0(
    "Unlimited recruitment of backfill patients is allowed.\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# RecruitmentRatio ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print RecruitmentRatio
knit_print.RecruitmentRatio <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  rv <- paste0(
    "Backfill patients are recruited at a ratio of ",
    x@ratio,
    " per patient in the main trial cohort.\n\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @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()
}

# 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",
      "backfill" = "Backfill cohorts"
    ),
    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,
    ignore_slots = "backfill",
    ...
  )
}

# 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,
    ignore_slots = "backfill"
  )
}

# 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", "backfill"),
      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 = c("model", "backfill"),
      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
  )
}

# 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()
}

#' @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
  )
}

#' 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
}

#' @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)
  }
)

#' 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)
}

# Backfill ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print Backfill
knit_print.Backfill <- function(
  x,
  ...,
  asis = TRUE
) {
  assert_flag(asis)

  if (is(x@opening, "OpeningNone")) {
    rv <- "No backfill cohorts at all will be opened.\n\n"
  } else {
    # Render the cohort size
    cohort_size_text <- paste0(
      "**Cohort size**: ",
      knit_print(x@cohort_size, asis = FALSE, ...),
      "\n"
    )

    # Render the opening rule
    opening_text <- paste0(
      "**Opening rule**: ",
      knit_print(x@opening, asis = FALSE, ...),
      "\n"
    )

    # Render the recruitment rule
    recruitment_text <- paste0(
      "**Recruitment**: ",
      knit_print(x@recruitment, asis = FALSE, ...),
      "\n"
    )

    # Render total size and priority
    max_size_text <- paste0(
      "**Total number of backfill patients**: ",
      ifelse(x@max_size >= 1e6, "Unlimited", x@max_size),
      " backfill patients.\n\n"
    )

    priority_text <- paste0(
      "**Priority of higher vs. lower dose backfill cohorts**: ",
      x@priority,
      " dose.\n\n"
    )

    rv <- paste0(
      cohort_size_text,
      opening_text,
      recruitment_text,
      max_size_text,
      priority_text
    )
  }

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @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)
  )
}

# Get the cohort index and dose of the previously added cohort.
h_previous_cohort <- function(data) {
  last_cohort_index <- length(data@cohort)
  last_cohort <- data@cohort[[last_cohort_index]]
  previous_cohort <- last_cohort - 1L
  previous_dose <- if (previous_cohort > 0) {
    data@x[data@cohort == previous_cohort][1]
  } else {
    NA_real_
  }
  list(
    cohort = previous_cohort,
    dose = previous_dose
  )
}

# Get the dose assigned to a given cohort.
h_get_dose_for_cohort <- function(data, cohort) {
  if (cohort > 0 && cohort <= length(data@cohort)) {
    data@x[data@cohort == cohort][1]
  } else {
    NA_real_
  }
}

# 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
    }
  }
)

#' @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()
  )
}

#' 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)
}

# 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
#' @importFrom Rdpack reprompt
#'
#' @keywords package
#' @references \insertRef{SabanesBoveYeungPalermoJaki2019}{crmPack}
"_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		#' 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	2599x	if (is.list(slot(obj, slot_name))) {
76	67x	return(
77	67x	lapply(
78	67x	slot(obj, slot_name),
79	67x	function(x) {
80	128x	if (is.data.frame(x)) {
81	11x	x
82	67x	} else if (
83	117x	is.list(x) &&
84	117x	stringr::str_detect(class(x)[1], stringr::fixed("tbl_"))
85		) {
86		# Already tidied to a list.
87	!	x
88	117x	} else if (is.numeric(x) \| is.character(x)) {
89		# tidy.numeric & tidy.character are deprecated
90	6x	tibble::tibble(!!{{ slot_name }} := x)
91		} else {
92	111x	x %>% tidy()
93		}
94		}
95		)
96		)
97		}
98	2532x	if (is(slot(obj, slot_name), "CrmPackClass")) {
99	356x	rv <- slot(obj, slot_name) %>%
100	356x	tidy()
101		} else {
102	2176x	if (is.null(col)) {
103	2176x	col <- slot_name
104		}
105	2176x	rv <- tibble::tibble({{ col }} := slot(obj, slot_name))
106		}
107	2532x	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	2532x	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	793x	slot_names <- slotNames(obj)
132	793x	rv <- list()
133	793x	for (nm in slot_names) {
134	2799x	if (!is.function(slot(obj, nm))) {
135	2539x	rv[[nm]] <- h_tidy_slot(obj, nm, ...)
136		}
137		}
138		# Column bind of all list elements have the same number of rows
139	793x	if (length(rv) > 1 && length(unique(sapply(rv, nrow))) == 1) {
140	401x	rv <- rv %>% dplyr::bind_cols() # nolint
141		}
142	793x	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	1682x	cls <- class(obj)
162	1682x	class(d) <- c(paste0("tbl_", cls[1]), class(d))
163	1682x	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	276x	vals <- x %>% dplyr::pull({{ col }})
207	276x	tibble(
208	276x	{{ min_col }} := c(range_min, vals),
209	276x	{{ 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		#' @slot backfilled (`logical`)\cr whether this patient was
69		#' in a backfill cohort.
70		#' @slot response (`integer`)\cr whether this patient had a
71		#' positive efficacy response (0 or 1 integers).
72		#'
73		#' @aliases Data
74		#' @export
75		#'
76		.Data <- setClass(
77		Class = "Data",
78		contains = "GeneralData",
79		slots = c(
80		x = "numeric",
81		y = "integer",
82		doseGrid = "numeric",
83		nGrid = "integer",
84		xLevel = "integer",
85		placebo = "logical",
86		backfilled = "logical",
87		response = "integer"
88		),
89		prototype = prototype(
90		x = numeric(),
91		y = integer(),
92		doseGrid = numeric(),
93		nGrid = 0L,
94		xLevel = integer(),
95		placebo = FALSE,
96		backfilled = logical(),
97		response = integer()
98		),
99		validity = v_data
100		)
101
102		## constructor ----
103
104		#' @rdname Data-class
105		#'
106		#' @details The `cohort` can be missing if and only if `placebo` is equal to
107		#' `FALSE`.
108		#'
109		#' @note `ID` and `cohort` can be missing. Then a message will be issued
110		#' and the variables will be filled with default IDs and best guesses cohort,
111		#' i.e. a sorted (in ascending order) sequence of values from `{1, 2, ...}`.
112		#'
113		#' @param x (`numeric`)\cr the doses for the patients.
114		#' @param y (`integer`)\cr the vector of toxicity events (0 or 1).
115		#' You can also supply `numeric` vectors, but these will then be converted to
116		#' `integer` internally.
117		#' @param ID (`integer`)\cr unique patient IDs.
118		#' You can also supply `numeric` vectors, but these will then be converted to
119		#' `integer` internally.
120		#' @param cohort (`integer`)\cr the cohort (non-negative sorted) indices.
121		#' You can also supply `numeric` vectors, but these will then be converted to
122		#' `integer` internally.
123		#' @param doseGrid (`numeric`)\cr all possible doses.
124		#' @param placebo (`flag`)\cr if `TRUE` the first dose level
125		#' in the `doseGrid` is considered as placebo.
126		#' @param backfilled (`logical`)\cr whether each patient was in
127		#' a backfill cohort.
128		#' @param response (`integer`)\cr whether each patient had a
129		#' positive efficacy response (1 = yes, 0 = no). May contain `NA`.
130		#' @param ... not used.
131		#'
132		#' @export
133		#' @example examples/Data-class.R
134		#'
135		Data <- function(
136		x = numeric(),
137		y = integer(),
138		ID = integer(),
139		cohort = integer(),
140		doseGrid = numeric(),
141		placebo = FALSE,
142		backfilled = rep(FALSE, length(x)),
143		response = rep(NA_integer_, length(x)),
144		...
145		) {
146	988x	assert_numeric(x)
147	988x	assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE)
148	988x	assert_integerish(ID, unique = TRUE, any.missing = FALSE)
149	988x	assert_integerish(cohort)
150	988x	if (length(x) > 0) {
151	701x	assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE, min.len = 1)
152		} else {
153	287x	assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
154		}
155	987x	assert_flag(placebo)
156	987x	assert_logical(backfilled, len = length(x), any.missing = FALSE)
157	987x	assert_integerish(
158	987x	response,
159	987x	len = length(x),
160	987x	lower = 0,
161	987x	upper = 1,
162	987x	any.missing = TRUE
163		)
164
165	987x	doseGrid <- sort(doseGrid)
166	987x	assert_subset(x, doseGrid)
167
168	987x	if (length(ID) == 0 && length(x) > 0) {
169	13x	message("Used default patient IDs!")
170	13x	ID <- seq_along(x)
171		} else {
172	974x	assert_integerish(ID, unique = TRUE)
173		}
174
175	987x	if (!placebo && length(cohort) == 0 && length(x) > 0) {
176	1x	message("Used best guess cohort indices!")
177		# This is just assuming that consecutive patients
178		# in the data set are in the same cohort if they
179		# have the same dose. Note that this could be wrong,
180		# if two subsequent cohorts are at the same dose.
181	1x	cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
182		} else {
183	986x	assert_integerish(cohort)
184		}
185
186	987x	.Data(
187	987x	x = as.numeric(x),
188	987x	y = as.integer(y),
189	987x	ID = as.integer(ID),
190	987x	cohort = as.integer(cohort),
191	987x	doseGrid = as.numeric(doseGrid),
192	987x	nObs = length(x),
193	987x	nGrid = length(doseGrid),
194	987x	xLevel = match_within_tolerance(x, doseGrid),
195	987x	placebo = placebo,
196	987x	backfilled = backfilled,
197	987x	response = as.integer(response)
198		)
199		}
200
201		## default constructor ----
202
203		#' @rdname Data-class
204		#' @note Typically, end users will not use the `.DefaultData()` function.
205		#' @export
206		.DefaultData <- function() {
207	18x	Data(
208	18x	doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
209	18x	ID = 1L:3L,
210	18x	cohort = 1L:3L,
211	18x	x = c(1, 3, 5),
212	18x	y = rep(0L, 3)
213		)
214		}
215
216		# DataDual ----
217
218		## class ----
219
220		#' `DataDual`
221		#'
222		#' @description `r lifecycle::badge("stable")`
223		#'
224		#' [`DataDual`] is a class for the dual endpoint data.
225		#' It inherits from [`Data`] and it contains additional biomarker information.
226		#'
227		#' @slot w (`numeric`)\cr the continuous vector of biomarker values.
228		#'
229		#' @aliases DataDual
230		#' @export
231		#'
232		.DataDual <- setClass(
233		Class = "DataDual",
234		slots = c(w = "numeric"),
235		prototype = prototype(w = numeric()),
236		contains = "Data",
237		validity = v_data_dual
238		)
239
240		## constructor ----
241
242		#' @rdname DataDual-class
243		#'
244		#' @param w (`numeric`)\cr the continuous vector of biomarker values.
245		#' @param ... parameters passed to [Data()].
246		#'
247		#' @export
248		#' @example examples/Data-class-DataDual.R
249		#'
250		DataDual <- function(w = numeric(), ...) {
251	205x	d <- Data(...)
252	205x	.DataDual(d, w = w)
253		}
254
255
256		## default constructor ----
257
258		#' @rdname DataDual-class
259		#' @note Typically, end users will not use the `.DefaultDataDual()` function.
260		#' @export
261		.DefaultDataDual <- function() {
262	8x	set.seed(1230)
263	8x	DataDual(
264	8x	x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
265	8x	y = c(0, 0, 0, 0, 0, 0, 1, 0),
266	8x	w = rnorm(8),
267	8x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
268	8x	ID = 1L:8L,
269	8x	cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
270		)
271		}
272
273		# DataParts ----
274
275		## class ----
276
277		#' `DataParts`
278		#'
279		#' @description `r lifecycle::badge("stable")`
280		#'
281		#' [`DataParts`] is a class for the data with two study parts.
282		#' It inherits from [`Data`] and it contains additional information
283		#' on the two study parts.
284		#'
285		#' @slot part (`integer`)\cr which part does each of the patients belong to?
286		#' @slot nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
287		#' @slot part1Ladder (`numeric`)\cr what is the escalation ladder for
288		#' part 1? This shall be an ordered subset of the `doseGrid`.
289		#'
290		#' @aliases DataParts
291		#' @export
292		#'
293		.DataParts <- setClass(
294		Class = "DataParts",
295		slots = c(
296		part = "integer",
297		nextPart = "integer",
298		part1Ladder = "numeric"
299		),
300		prototype = prototype(
301		part = integer(),
302		nextPart = 1L,
303		part1Ladder = numeric()
304		),
305		contains = "Data",
306		validity = v_data_parts
307		)
308
309		## constructor ----
310
311		#' @rdname DataParts-class
312		#'
313		#' @param part (`integer`)\cr which part does each of the patients belong to?
314		#' @param nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
315		#' @param part1Ladder (`numeric`)\cr what is the escalation ladder for part 1?
316		#' This shall be an ordered subset of the `doseGrid`.
317		#' @param ... parameters passed to [Data()].
318		#'
319		#' @export
320		#' @example examples/Data-class-DataParts.R
321		#'
322		DataParts <- function(
323		part = integer(),
324		nextPart = 1L,
325		part1Ladder = numeric(),
326		...
327		) {
328	28x	d <- Data(...)
329	28x	.DataParts(
330	28x	d,
331	28x	part = part,
332	28x	nextPart = nextPart,
333	28x	part1Ladder = part1Ladder
334		)
335		}
336
337		## default constructor ----
338
339		#' @rdname DataParts-class
340		#' @note Typically, end users will not use the `.DefaultDataParts()` function.
341		#' @export
342		.DefaultDataParts <- function() {
343	7x	DataParts(
344	7x	x = c(0.1, 0.5, 1.5),
345	7x	y = c(0, 0, 0),
346	7x	ID = 1:3,
347	7x	cohort = 1:3,
348	7x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
349	7x	part = c(1L, 1L, 1L),
350	7x	nextPart = 1L,
351	7x	part1Ladder = c(0.1, 0.5, 1.5, 3, 6, 10)
352		)
353		}
354
355
356		# DataMixture ----
357
358		## class ----
359
360		#' `DataMixture`
361		#'
362		#' @description `r lifecycle::badge("stable")`
363		#'
364		#' [`DataMixture`] is a class for the data with mixture sharing.
365		#' It inherits from [`Data`] and it contains additional information
366		#' on the mixture sharing.
367		#'
368		#' @slot xshare (`numeric`)\cr the doses for the share patients.
369		#' @slot yshare (`integer`)\cr the vector of toxicity events (0 or 1)
370		#' for the share patients.
371		#' @slot nObsshare (`count`)\cr number of share patients.
372		#'
373		#' @aliases DataMixture
374		#' @export
375		#'
376		.DataMixture <- setClass(
377		Class = "DataMixture",
378		slots = c(
379		xshare = "numeric",
380		yshare = "integer",
381		nObsshare = "integer"
382		),
383		prototype = prototype(
384		xshare = numeric(),
385		yshare = integer(),
386		nObsshare = 0L
387		),
388		contains = "Data",
389		validity = v_data_mixture
390		)
391
392		## constructor ----
393
394		#' @rdname DataMixture-class
395		#'
396		#' @param xshare (`numeric`)\cr the doses for the share patients.
397		#' @param yshare (`integer`)\cr the vector of toxicity events (0 or 1)
398		#' for the share patients. You can also supply `numeric` vectors,
399		#' but these will then be converted to `integer` internally.
400		#' @param ... parameters passed to [Data()].
401		#'
402		#' @export
403		#' @example examples/Data-class-DataMixture.R
404		#'
405		DataMixture <- function(xshare = numeric(), yshare = integer(), ...) {
406	10x	d <- Data(...)
407	10x	assert_integerish(yshare)
408	10x	assert_numeric(xshare)
409	10x	.DataMixture(
410	10x	d,
411	10x	xshare = as.numeric(xshare),
412	10x	yshare = as.integer(yshare),
413	10x	nObsshare = length(xshare)
414		)
415		}
416
417		## default constructor ----
418
419		#' @rdname DataMixture-class
420		#' @note Typically, end users will not use the `.DefaultDataMixture()` function.
421		#' @export
422		.DefaultDataMixture <- function() {
423	8x	DataMixture(
424	8x	xshare = c(12, 14, 16, 18.0),
425	8x	yshare = c(0L, 1L, 1L, 1L),
426	8x	nObsshare = 4L,
427	8x	x = c(0.1, 0.5, 1.5),
428	8x	y = c(0, 0, 0),
429	8x	ID = 1L:3L,
430	8x	cohort = 1L:3L,
431	8x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2))
432		)
433		}
434
435
436		# DataDA ----
437
438		## class ----
439
440		#' `DataDA`
441		#'
442		#' @description `r lifecycle::badge("stable")`
443		#'
444		#' [`DataDA`] is a class for the time-to-DLT augmented data.
445		#' It inherits from [`Data`] and it contains additional DLT free survival times.
446		#'
447		#' @note `survival time` here refers to the time period for which the subject
448		#' did not experience any DLT, and is not referring to deaths.
449		#'
450		#' @slot u (`numeric`)\cr the continuous vector of DLT free survival times.
451		#' @slot t0 (`numeric`)\cr time of initial dosing for each patient.
452		#' Non-negative values sorted in ascending order.
453		#' @slot Tmax (`number`)\cr the DLT observation period.
454		#'
455		#' @aliases DataDA
456		#' @export
457		#'
458		.DataDA <- setClass(
459		Class = "DataDA",
460		slots = c(
461		u = "numeric",
462		t0 = "numeric",
463		Tmax = "numeric"
464		),
465		prototype = prototype(
466		u = numeric(),
467		t0 = numeric(),
468		Tmax = 0 + .Machine$double.xmin
469		),
470		contains = "Data",
471		validity = v_data_da
472		)
473
474		## constructor ----
475
476		#' @rdname DataDA-class
477		#'
478		#' @param u (`numeric`)\cr the continuous vector of DLT free survival times.
479		#' @param t0 (`numeric`)\cr time of initial dosing for each patient.
480		#' Non-negative values sorted in ascending order.
481		#' Default to vector of 0s of length equal to length of `u`.
482		#' @param Tmax (`number`)\cr the DLT observation period.
483		#' @param ... parameters passed to [Data()].
484		#'
485		#' @export
486		#' @example examples/Data-class-DataDA.R
487		#'
488		DataDA <- function(
489		u = numeric(),
490		t0 = numeric(length(u)),
491		Tmax = 0 + .Machine$double.xmin,
492		...
493		) {
494	32x	d <- Data(...)
495	32x	.DataDA(
496	32x	d,
497	32x	u = as.numeric(u),
498	32x	t0 = as.numeric(t0),
499	32x	Tmax = as.numeric(Tmax)
500		)
501		}
502
503		## default constructor ----
504
505		#' @rdname DataDA-class
506		#' @note Typically, end users will not use the `.DefaultDataDA()` function.
507		#' @export
508		.DefaultDataDA <- function() {
509	8x	DataDA(
510	8x	u = c(42, 30, 15, 5, 20, 25, 30, 60),
511	8x	t0 = c(0, 15, 30, 40, 55, 70, 75, 85),
512	8x	Tmax = 60,
513	8x	x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
514	8x	y = c(0, 0, 1, 1, 0, 0, 1, 0),
515	8x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
516	8x	ID = 1L:8L,
517	8x	cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
518		)
519		}
520
521		# DataOrdinal ----
522
523		## class ----
524
525		#' `DataOrdinal`
526		#'
527		#' @description `r lifecycle::badge("experimental")`
528		#'
529		#' [`DataOrdinal`] is a class for ordinal toxicity data.
530		#' It inherits from [`GeneralData`] and it describes toxicity responses on an
531		#' ordinal rather than binary scale.
532		#'
533		#' @note This class has been implemented as a sibling of the existing `Data` class
534		#' (rather than as a parent or child) to minimise the risk of unintended side
535		#' effects on existing classes and methods.
536		#'
537		#' The default setting for the `yCategories` slot replicates the behaviour
538		#' of the existing `Data` class.
539		#'
540		#' @aliases DataOrdinal
541		#' @export
542		.DataOrdinal <- setClass(
543		Class = "DataOrdinal",
544		contains = "GeneralData",
545		slots = c(
546		x = "numeric",
547		y = "integer",
548		doseGrid = "numeric",
549		nGrid = "integer",
550		xLevel = "integer",
551		yCategories = "integer",
552		placebo = "logical"
553		),
554		prototype = prototype(
555		x = numeric(),
556		y = integer(),
557		doseGrid = numeric(),
558		nGrid = 0L,
559		xLevel = integer(),
560		yCategories = c("No DLT" = 0L, "DLT" = 1L),
561		placebo = FALSE
562		),
563		validity = v_data_ordinal
564		)
565
566		## constructor ----
567
568		#' @rdname DataOrdinal-class
569		#' @param yCategories (named `integer`)\cr the names and codes for the
570		#' toxicity categories used in the data. Category labels are taken from the
571		#' names of the vector. The names of the vector must be unique and its values
572		#' must be sorted and take the values 0, 1, 2, ...
573		#' @inheritParams Data
574		#' @inherit Data details note params
575		#' @example examples/Data-class-DataOrdinal.R
576		#' @export
577		DataOrdinal <- function(
578		x = numeric(),
579		y = integer(),
580		ID = integer(),
581		cohort = integer(),
582		doseGrid = numeric(),
583		placebo = FALSE,
584		yCategories = c("No DLT" = 0L, "DLT" = 1L),
585		...
586		) {
587	76x	assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
588	76x	assert_integerish(
589	76x	yCategories,
590	76x	any.missing = FALSE,
591	76x	unique = TRUE,
592	76x	names = "unique",
593	76x	min.len = 2
594		)
595	76x	assert_flag(placebo)
596
597	76x	doseGrid <- as.numeric(sort(doseGrid))
598
599	76x	if (length(ID) == 0 && length(x) > 0) {
600	!	message("Used default patient IDs!")
601	!	ID <- seq_along(x)
602		} else {
603	76x	assert_integerish(ID, unique = TRUE)
604		}
605
606	76x	if (!placebo && length(cohort) == 0 && length(x) > 0) {
607	!	message("Used best guess cohort indices!")
608		# This is just assuming that consecutive patients
609		# in the data set are in the same cohort if they
610		# have the same dose. Note that this could be wrong,
611		# if two subsequent cohorts are at the same dose.
612	!	cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
613		} else {
614	76x	assert_integerish(cohort)
615		}
616
617	76x	.DataOrdinal(
618	76x	x = as.numeric(x),
619	76x	y = as.integer(y),
620	76x	ID = as.integer(ID),
621	76x	cohort = as.integer(cohort),
622	76x	doseGrid = doseGrid,
623	76x	nObs = length(x),
624	76x	nGrid = length(doseGrid),
625	76x	xLevel = match_within_tolerance(x = x, table = doseGrid),
626	76x	placebo = placebo,
627	76x	yCategories = yCategories
628		)
629		}
630
631
632		## default constructor ----
633
634		#' @rdname DataOrdinal-class
635		#' @note Typically, end users will not use the `.DefaultDataOrdinal()` function.
636		#' @export
637		.DefaultDataOrdinal <- function() {
638	24x	DataOrdinal(
639	24x	x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
640	24x	y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
641	24x	ID = 1L:10L,
642	24x	cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
643	24x	doseGrid = c(seq(from = 10, to = 100, by = 10)),
644	24x	yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
645	24x	placebo = FALSE
646		)
647		}
648
649		# DataGrouped ----
650
651		## class ----
652
653		#' `DataGrouped`
654		#'
655		#' @description `r lifecycle::badge("stable")`
656		#'
657		#' [`DataGrouped`] is a class for a two groups dose escalation data set,
658		#' comprised of a monotherapy (`mono`) and a combination therapy (`combo`)
659		#' arm. It inherits from [`Data`] and it contains the additional group information.
660		#'
661		#' @slot group (`factor`)\cr whether `mono` or `combo` was used.
662		#'
663		#' @aliases DataGrouped
664		#' @export
665		.DataGrouped <- setClass(
666		Class = "DataGrouped",
667		slots = c(
668		group = "factor"
669		),
670		prototype = prototype(
671		group = factor(levels = c("mono", "combo"))
672		),
673		contains = "Data",
674		validity = v_data_grouped
675		)
676
677		#' @rdname DataGrouped-class
678		#'
679		#' @param group (`factor` or `character`)\cr whether `mono` or `combo` was used.
680		#' If `character` then will be coerced to `factor` with the correct levels
681		#' internally.
682		#' @param ... parameters passed to [Data()].
683		#'
684		#' @export
685		#' @example examples/Data-class-DataGrouped.R
686		#'
687		DataGrouped <- function(group = character(), ...) {
688	83x	d <- Data(...)
689	83x	if (!is.factor(group)) {
690	83x	assert_character(group)
691	83x	assert_subset(group, choices = c("mono", "combo"))
692	83x	group <- factor(group, levels = c("mono", "combo"))
693		}
694	83x	.DataGrouped(
695	83x	d,
696	83x	group = group
697		)
698		}
699
700		## default constructor ----
701
702		#' @rdname DataGrouped-class
703		#' @note Typically, end users will not use the `.DefaultDataGrouped()` function.
704		#' @export
705		.DefaultDataGrouped <- function() {
706	9x	DataGrouped(
707	9x	group = c("mono", "mono", "combo"),
708	9x	x = c(1, 3, 5),
709	9x	y = c(0, 0, 0),
710	9x	ID = 1L:3L,
711	9x	cohort = 1L:3L,
712	9x	doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
713	9x	placebo = FALSE
714		)
715		}

1		#' @include helpers.R
2		#' @include Rules-class.R
3		#' @include CrmPackClass-class.R
4		#' @include Backfill-validity.R
5		NULL
6
7		# Opening ----
8
9		## class ----
10
11		#' `Opening`
12		#'
13		#' @description `r lifecycle::badge("experimental")`
14		#'
15		#' [`Opening`] is a virtual class for opening criteria, from which all
16		#' other specific opening criteria classes inherit.
17		#' The subclasses are used for backfill cohort designs.
18		#'
19		#' @seealso [`OpeningMinDose`], [`OpeningMinCohorts`], [`OpeningNone`],
20		#' [`OpeningMinResponses`], [`OpeningAll`], [`OpeningAny`].
21		#'
22		#' @aliases Opening
23		#' @export
24		#'
25		.Opening <- setClass(
26		Class = "Opening",
27		contains = "CrmPackClass"
28		)
29
30		## default constructor ----
31
32		#' @rdname Opening-class
33		#' @note Typically, end users will not use the `.DefaultOpening()` function.
34		#' @export
35		.DefaultOpening <- function() {
36	!	stop(
37	!	paste(
38	!	"Class Opening should not be instantiated directly.",
39	!	"Please use one of its subclasses instead."
40		)
41		)
42		}
43
44		# OpeningMinDose ----
45
46		## class ----
47
48		#' `OpeningMinDose`
49		#'
50		#' @description `r lifecycle::badge("experimental")`
51		#'
52		#' [`OpeningMinDose`] opens a backfill cohort when the
53		#' cohort's dose is above or equal to the minimum dose specified.
54		#' Note that the next recommended dose is not taken into account.
55		#'
56		#' @slot min_dose (`number`)\cr the minimum dose at which backfill
57		#' cohorts can be opened.
58		#'
59		#' @seealso [`Opening`] and the other subclasses listed in there.
60		#'
61		#' @aliases OpeningMinDose
62		#' @export
63		.OpeningMinDose <- setClass(
64		Class = "OpeningMinDose",
65		slots = c(min_dose = "numeric"),
66		prototype = list(min_dose = 0),
67		contains = "Opening",
68		validity = v_opening_min_dose
69		)
70
71		## constructor ----
72
73		#' @rdname OpeningMinDose-class
74		#'
75		#' @param min_dose (`number`)\cr see slot definition.
76		#'
77		#' @export
78		#' @example examples/Backfill-class-OpeningMinDose.R
79		OpeningMinDose <- function(min_dose = 0) {
80	105x	.OpeningMinDose(min_dose = min_dose)
81		}
82
83		## default constructor ----
84
85		#' @rdname OpeningMinDose-class
86		#' @note Typically, end users will not use the `.DefaultOpeningMinDose()` function.
87		#' @export
88		.DefaultOpeningMinDose <- function() {
89	9x	OpeningMinDose()
90		}
91
92		# OpeningMinCohorts ----
93
94		## class ----
95
96		#' `OpeningMinCohorts`
97		#'
98		#' @description `r lifecycle::badge("experimental")`
99		#'
100		#' [`OpeningMinCohorts`] opens backfill cohorts when the overall number of
101		#' cohorts treated so far in the trial reaches or exceeds a minimum threshold.
102		#' This can be used to implement a "delayed backfill cohort opening" rule.
103		#'
104		#' @slot min_cohorts (`integer`)\cr the minimum number of cohorts that must
105		#' have been treated before backfilling can be opened.
106		#'
107		#' @seealso [`Opening`] and the other subclasses listed in there.
108		#'
109		#' @aliases OpeningMinCohorts
110		#' @export
111		#'
112		.OpeningMinCohorts <- setClass(
113		Class = "OpeningMinCohorts",
114		slots = c(min_cohorts = "integer"),
115		prototype = list(min_cohorts = 2L),
116		contains = "Opening",
117		validity = v_opening_min_cohorts
118		)
119
120		## constructor ----
121
122		#' @rdname OpeningMinCohorts-class
123		#'
124		#' @param min_cohorts (`integer`)\cr see slot definition.
125		#'
126		#' @export
127		#'
128		OpeningMinCohorts <- function(min_cohorts = 2L) {
129	36x	assert_integerish(min_cohorts, len = 1, lower = 1)
130	36x	min_cohorts <- as.integer(min_cohorts)
131	36x	.OpeningMinCohorts(min_cohorts = min_cohorts)
132		}
133
134		## default constructor ----
135
136		#' @rdname OpeningMinCohorts-class
137		#' @note Typically, end users will not use the `.DefaultOpeningMinCohorts()` function.
138		#' @export
139		.DefaultOpeningMinCohorts <- function() {
140	9x	OpeningMinCohorts()
141		}
142
143		# OpeningNone ----
144
145		## class ----
146
147		#' `OpeningNone`
148		#'
149		#' @description `r lifecycle::badge("experimental")`
150		#'
151		#' [`OpeningNone`] never opens any backfill cohorts. This can be used when
152		#' no backfill cohorts should be available in a trial design.
153		#'
154		#' @aliases OpeningNone
155		#' @export
156		#'
157		.OpeningNone <- setClass(
158		Class = "OpeningNone",
159		contains = "Opening"
160		)
161
162		## constructor ----
163
164		#' @rdname OpeningNone-class
165		#'
166		#' @export
167		#'
168		OpeningNone <- function() {
169	84x	.OpeningNone()
170		}
171
172		## default constructor ----
173
174		#' @rdname OpeningNone-class
175		#' @note Typically, end users will not use the `.DefaultOpeningNone()` function.
176		#' @export
177		.DefaultOpeningNone <- function() {
178	9x	OpeningNone()
179		}
180
181		# OpeningMinResponses ----
182
183		## class ----
184
185		#' `OpeningMinResponses`
186		#'
187		#' @description `r lifecycle::badge("experimental")`
188		#'
189		#' [`OpeningMinResponses`] opens backfill cohorts when a minimum number of
190		#' responses has been observed in the trial. The responses can be counted
191		#' at the cohort's dose level only, or also at lower dose levels if
192		#' `include_lower_doses` is set to `TRUE`.
193		#'
194		#' @slot min_responses (`count`)\cr the minimum number of responses
195		#' required before backfill cohorts can be opened (at least 1).
196		#' @slot include_lower_doses (`logical`)\cr if `TRUE`, responses at all
197		#' doses less than or equal to the cohort's dose are counted. If `FALSE`,
198		#' only responses at the cohort's dose are counted.
199		#'
200		#' @seealso [`Opening`] and the other subclasses listed in there.
201		#'
202		#' @aliases OpeningMinResponses
203		#' @export
204		#'
205		.OpeningMinResponses <- setClass(
206		Class = "OpeningMinResponses",
207		slots = c(
208		min_responses = "integer",
209		include_lower_doses = "logical"
210		),
211		prototype = list(
212		min_responses = 1L,
213		include_lower_doses = FALSE
214		),
215		contains = "Opening",
216		validity = v_opening_min_responses
217		)
218
219		## constructor ----
220
221		#' @rdname OpeningMinResponses-class
222		#'
223		#' @param min_responses (`count`)\cr see slot definition.
224		#' @param include_lower_doses (`logical`)\cr see slot definition.
225		#'
226		#' @export
227		#' @example examples/Backfill-class-OpeningMinResponses.R
228		OpeningMinResponses <- function(
229		min_responses = 1L,
230		include_lower_doses = FALSE
231		) {
232	23x	assert_count(min_responses, positive = TRUE)
233	23x	assert_flag(include_lower_doses)
234	23x	min_responses <- as.integer(min_responses)
235	23x	.OpeningMinResponses(
236	23x	min_responses = min_responses,
237	23x	include_lower_doses = include_lower_doses
238		)
239		}
240
241		## default constructor ----
242
243		#' @rdname OpeningMinResponses-class
244		#' @note Typically, end users will not use the `.DefaultOpeningMinResponses()` function.
245		#' @export
246		.DefaultOpeningMinResponses <- function() {
247	9x	OpeningMinResponses()
248		}
249
250
251		# OpeningList and logical operators ----
252
253		## OpeningList ----
254
255		#' `OpeningList`
256		#'
257		#' @description `r lifecycle::badge("experimental")`
258		#'
259		#' [`OpeningList`] is a virtual class for combining multiple [`Opening`] objects
260		#' using logical operators. It is used as a base class for [`OpeningAll`] and
261		#' [`OpeningAny`].
262		#'
263		#' @slot open_list (`list`)
264		#' a list of [`Opening`] objects to be combined.
265		#'
266		#' @seealso [`Opening`], [`OpeningAll`], [`OpeningAny`].
267		#'
268		#' @aliases OpeningList
269		#' @export
270		#'
271		.OpeningList <- setClass(
272		Class = "OpeningList",
273		contains = "Opening",
274		slots = list(open_list = "list")
275		)
276
277		## constructor ----
278
279		#' @rdname OpeningList-class
280		#'
281		#' @param ... (`Opening`)\cr opening objects to combine.
282		#' @export
283		#' @example examples/Backfill-class-OpeningList.R
284		OpeningList <- function(...) {
285	38x	args <- list(...)
286	38x	assert_list(args, min.len = 1)
287	38x	for (arg in args) {
288	76x	assert_class(arg, "Opening")
289		}
290	38x	.OpeningList(open_list = args)
291		}
292
293		## default constructor ----
294
295		#' @rdname OpeningList-class
296		#' @note Typically, end users will not use the `.DefaultOpeningList()` function.
297		#' @export
298		.DefaultOpeningList <- function() {
299	8x	OpeningList(OpeningMinDose(), OpeningMinDose())
300		}
301
302		## OpeningAll ----
303
304		#' `OpeningAll`
305		#'
306		#' @description `r lifecycle::badge("experimental")`
307		#'
308		#' [`OpeningAll`] combines multiple [`Opening`] objects using AND logic.
309		#' A backfill cohort is opened only if ALL opening criteria in the list
310		#' are satisfied. This can also be created using the `&` operator.
311		#'
312		#' @slot open_list (`list`)
313		#' a list of [`Opening`] objects to be combined with AND logic.
314		#'
315		#' @seealso [`Opening`], [`OpeningAny`], [`OpeningList`].
316		#'
317		#' @aliases OpeningAll
318		#' @export
319		#'
320		.OpeningAll <- setClass(
321		Class = "OpeningAll",
322		contains = "OpeningList"
323		)
324
325		## constructor ----
326
327		#' @rdname OpeningAll-class
328		#'
329		#' @param ... (`Opening`)
330		#' opening objects to combine with AND logic.
331		#'
332		#' @export
333		#' @example examples/Backfill-class-OpeningAll.R
334		OpeningAll <- function(...) {
335	15x	start <- OpeningList(...)
336	15x	.OpeningAll(start)
337		}
338
339		## default constructor ----
340
341		#' @rdname OpeningAll-class
342		#' @note Typically, end users will not use the `.DefaultOpeningAll()` function.
343		#' @export
344		.DefaultOpeningAll <- function() {
345	9x	OpeningAll(OpeningMinDose(), OpeningMinDose())
346		}
347
348		## OpeningAny ----
349
350		#' `OpeningAny`
351		#'
352		#' @description `r lifecycle::badge("experimental")`
353		#'
354		#' [`OpeningAny`] combines multiple [`Opening`] objects using OR logic.
355		#' A backfill cohort is opened if ANY opening criteria in the list
356		#' are satisfied. This can also be created using the `\|` operator.
357		#'
358		#' @slot open_list (`list`)\cr a list of [`Opening`] objects to be
359		#' combined with OR logic.
360		#'
361		#' @seealso [`Opening`], [`OpeningAll`], [`OpeningList`].
362		#'
363		#' @aliases OpeningAny
364		#' @export
365		#'
366		.OpeningAny <- setClass(
367		Class = "OpeningAny",
368		contains = "OpeningList"
369		)
370
371		## constructor ----
372
373		#' @rdname OpeningAny-class
374		#'
375		#' @param ... (`Opening`)
376		#' opening objects to combine with OR logic.
377		#'
378		#' @export
379		#' @example examples/Backfill-class-OpeningAny.R
380		OpeningAny <- function(...) {
381	14x	start <- OpeningList(...)
382	14x	.OpeningAny(start)
383		}
384
385		## default constructor ----
386
387		#' @rdname OpeningAny-class
388		#' @note Typically, end users will not use the `.DefaultOpeningAny()` function.
389		#' @export
390		.DefaultOpeningAny <- function() {
391	9x	OpeningAny(OpeningMinDose(), OpeningMinDose())
392		}
393
394		# Recruitment ----
395
396		## class ----
397
398		#' `Recruitment`
399		#'
400		#' @description `r lifecycle::badge("experimental")`
401		#'
402		#' [`Recruitment`] is a virtual class for recruitment criteria, from which all
403		#' other specific recruitment criteria classes inherit.
404		#' The subclasses are used to specify the maximum number of backfill patients
405		#' that can be recruited relative to the main trial cohort size.
406		#'
407		#' @seealso [`RecruitmentUnlimited`], [`RecruitmentRatio`].
408		#'
409		#' @aliases Recruitment
410		#' @export
411		#'
412		.Recruitment <- setClass(
413		Class = "Recruitment",
414		contains = "CrmPackClass"
415		)
416
417		## default constructor ----
418
419		#' @rdname Recruitment-class
420		#' @note Typically, end users will not use the `.DefaultRecruitment()` function.
421		#' @export
422		.DefaultRecruitment <- function() {
423	!	stop(
424	!	paste(
425	!	"Class Recruitment should not be instantiated directly.",
426	!	"Please use one of its subclasses instead."
427		)
428		)
429		}
430
431		# RecruitmentUnlimited ----
432
433		## class ----
434
435		#' `RecruitmentUnlimited`
436		#'
437		#' @description `r lifecycle::badge("experimental")`
438		#'
439		#' [`RecruitmentUnlimited`] allows unlimited recruitment of backfill patients.
440		#' There is no constraint on the number of backfill patients relative to the
441		#' main trial cohort size.
442		#'
443		#' @seealso [`Recruitment`] and the other subclasses listed in there.
444		#'
445		#' @aliases RecruitmentUnlimited
446		#' @export
447		#'
448		.RecruitmentUnlimited <- setClass(
449		Class = "RecruitmentUnlimited",
450		contains = "Recruitment"
451		)
452
453		## constructor ----
454
455		#' @rdname RecruitmentUnlimited-class
456		#'
457		#' @export
458		#' @example examples/Backfill-class-RecruitmentUnlimited.R
459		RecruitmentUnlimited <- function() {
460	101x	.RecruitmentUnlimited()
461		}
462
463		## default constructor ----
464
465		#' @rdname RecruitmentUnlimited-class
466		#' @note Typically, end users will not use the `.DefaultRecruitmentUnlimited()` function.
467		#' @export
468		.DefaultRecruitmentUnlimited <- function() {
469	9x	RecruitmentUnlimited()
470		}
471
472		# RecruitmentRatio ----
473
474		## class ----
475
476		#' `RecruitmentRatio`
477		#'
478		#' @description `r lifecycle::badge("experimental")`
479		#'
480		#' [`RecruitmentRatio`] constrains the recruitment of backfill patients
481		#' based on a ratio to the main trial cohort size. The maximum number of
482		#' backfill patients is calculated as `ceiling(ratio * active_cohort_size)`.
483		#'
484		#' @slot ratio (`number`)
485		#' the recruitment ratio, specifying the maximum number of backfill patients
486		#' per patient in the main trial cohort (non-negative).
487		#'
488		#' @seealso [`Recruitment`] and the other subclasses listed in there.
489		#'
490		#' @aliases RecruitmentRatio
491		#' @export
492		#'
493		.RecruitmentRatio <- setClass(
494		Class = "RecruitmentRatio",
495		contains = "Recruitment",
496		slots = list(ratio = "numeric"),
497		validity = v_recruitment_ratio
498		)
499
500		## constructor ----
501
502		#' @rdname RecruitmentRatio-class
503		#'
504		#' @param ratio (`number`)
505		#' see slot definition.
506		#'
507		#' @export
508		#' @example examples/Backfill-class-RecruitmentRatio.R
509		RecruitmentRatio <- function(ratio = 1) {
510	32x	assert_numeric(ratio, len = 1, lower = 0)
511	32x	.RecruitmentRatio(ratio = ratio)
512		}
513
514		## default constructor ----
515
516		#' @rdname RecruitmentRatio-class
517		#' @note Typically, end users will not use the `.DefaultRecruitmentRatio()` function.
518		#' @export
519		.DefaultRecruitmentRatio <- function() {
520	9x	RecruitmentRatio()
521		}
522
523		# Backfill ----
524
525		## class ----
526
527		#' `Backfill` class
528		#'
529		#' @description `r lifecycle::badge("experimental")`
530		#'
531		#' Class representing a backfilling rule in a clinical trial design.
532		#'
533		#' @slot cohort_size (`CohortSize`)\cr the size of cohorts to be backfilled.
534		#' @slot opening (`Opening`)\cr the opening criteria for backfilling.
535		#' @slot recruitment (`Recruitment`)\cr recruitment criteria for backfilling.
536		#' @slot max_size (`count`)\cr the maximum number of patients to be backfilled.
537		#' @slot priority (`character`)\cr the priority rule for backfilling,
538		#' one of "highest", "lowest", or "random".
539		#'
540		#' @aliases Backfill
541		#' @export
542		.Backfill <- setClass(
543		Class = "Backfill",
544		slots = list(
545		cohort_size = "CohortSize",
546		opening = "Opening",
547		recruitment = "Recruitment",
548		max_size = "integer",
549		priority = "character"
550		),
551		prototype = prototype(
552		cohort_size = CohortSizeConst(size = 3),
553		opening = .OpeningMinDose(),
554		recruitment = .RecruitmentUnlimited(),
555		max_size = 1e6L,
556		priority = "highest"
557		),
558		contains = "CrmPackClass",
559		validity = v_backfill
560		)
561
562		## constructor ----
563
564		#' @rdname Backfill-class
565		#'
566		#' @param cohort_size (`CohortSize`)\cr see the slot definition.
567		#' @param opening (`Opening`)\cr see the slot definition.
568		#' @param recruitment (`Recruitment`)\cr see the slot definition.
569		#' @param max_size (`count`)\cr see the slot definition.
570		#' @param priority (`character`)\cr see the slot definition.
571		#' @return An object of class `Backfill`.
572		#'
573		#' @export
574		Backfill <- function(
575		cohort_size = CohortSizeConst(size = 3),
576		opening = OpeningMinDose(),
577		recruitment = RecruitmentUnlimited(),
578		max_size = 1e6L,
579		priority = c("highest", "lowest", "random")
580		) {
581	94x	assert_count(max_size, positive = TRUE)
582	94x	max_size <- as.integer(max_size)
583	94x	priority <- match.arg(priority)
584
585	94x	.Backfill(
586	94x	cohort_size = cohort_size,
587	94x	opening = opening,
588	94x	recruitment = recruitment,
589	94x	max_size = max_size,
590	94x	priority = priority
591		)
592		}
593
594		## default constructor ----
595
596		#' @rdname Backfill-class
597		#' @note Typically, end users will not use the `.DefaultBackfill()` function.
598		#' @export
599		.DefaultBackfill <- function() {
600	8x	Backfill()
601		}

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	219x	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	105x	assert_true(h_test_named_numeric(sigma2W, permutation.of = c("a", "b")))
37	104x	comp$priormodel <- h_jags_join_models(
38	104x	comp$priormodel,
39	104x	function() {
40	!	precW ~ dgamma(precWa, precWb)
41		}
42		)
43	104x	comp$modelspecs$precWa <- sigma2W[["a"]]
44	104x	comp$modelspecs$precWb <- sigma2W[["b"]]
45	104x	comp$init$precW <- 1
46	104x	comp$sample <- c(comp$sample, "precW")
47		}
48	216x	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	220x	rmin <- .Machine$double.xmin
81	220x	if (use_fixed) {
82	115x	assert_number(rho, lower = -1 + rmin, upper = 1 - rmin)
83	112x	comp$modelspecs$rho <- rho
84		} else {
85	105x	assert_true(h_test_named_numeric(rho, permutation.of = c("a", "b")))
86	104x	comp$priormodel <- h_jags_join_models(
87	104x	comp$priormodel,
88	104x	function() {
89	!	kappa ~ dbeta(rhoa, rhob)
90	!	rho <- 2 * kappa - 1
91		}
92		)
93	104x	comp$modelspecs$rhoa <- rho[["a"]]
94	104x	comp$modelspecs$rhob <- rho[["b"]]
95	104x	comp$init$kappa <- 0.5
96	104x	comp$sample <- c(comp$sample, "rho")
97		}
98	216x	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	66x	modelspecs <- de@modelspecs
130	66x	init <- de@init
131
132	66x	if (use_fixed) {
133	54x	assert_number(sigma2betaW, lower = 0 + .Machine$double.xmin, finite = TRUE)
134	52x	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	63x	de@modelspecs <- function(from_prior) {
151	45x	c(modelspecs(from_prior), ms)
152		}
153	63x	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	193x	assert_numeric(param, min.len = 1, max.len = 2, any.missing = FALSE)
200	192x	assert_string(param_name)
201	191x	assert_class(de, "DualEndpoint")
202
203	191x	use_fixed <- setNames(test_number(param), param_name)
204	191x	modelspecs <- de@modelspecs
205	191x	init <- de@init
206
207	191x	if (use_fixed) {
208	81x	ms <- setNames(list(param), param_name)
209		} else {
210	110x	assert_character(param_suffix, len = 2, unique = TRUE, any.missing = FALSE)
211	109x	assert_function(priormodel)
212	108x	param_name2 <- paste0(param_name, param_suffix)
213
214	108x	de@priormodel <- h_jags_join_models(
215	108x	de@priormodel,
216	108x	priormodel
217		)
218	108x	ms <- setNames(list(param[1], param[2]), param_name2)
219	108x	de@init <- function(y) {
220	21x	c(init(y), setNames(list(mean(param)), param_name))
221		}
222	108x	de@sample <- c(de@sample, param_name)
223		}
224	189x	de@modelspecs <- function(from_prior) {
225	60x	c(modelspecs(from_prior), ms)
226		}
227	189x	de@use_fixed <- c(de@use_fixed, use_fixed)
228	189x	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	23x	assert_integer(grade, len = 1, lower = 1)
249	23x	assert_class(x, "LogisticLogNormalOrdinal")
250		# Execute
251	23x	LogisticLogNormal(
252	23x	mean = x@params@mean[-grade],
253	23x	cov = x@params@cov[-grade, -grade],
254	23x	ref_dose = x@ref_dose
255		)
256		}

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
7		#'
8		#' @return a character string that represents the object in markdown.
9		#' @name knit_print
10		NULL
11
12		# CohortSize ----
13
14		#' Render a `CohortSizeConst` Object
15		#'
16		#' @description `r lifecycle::badge("experimental")`
17		#' @param x (`CohortSize`)\cr The object to knit_print.
18		#' @param asis (`flag`)\cr Should the return value be wrapped in a call to `knitr::asis_output`?
19		#' @param label (`character`)\cr The word used to label the participants. See Usage Notes below.
20		#' @param ... Not used at present
21		#'
22		#' @section Usage Notes:
23		#' `label` describes the trial's participants.
24		#'
25		#' It should be a character vector of length 1 or 2. If of length 2, the first
26		#' element describes a `cohort_size` of 1 and the second describes all other
27		#' `cohort_size`s. If of length 1, the character `s` is appended to the value
28		#' when `cohort_size` is not 1.
29		#' @return The markdown representation of the object, as a character string
30		#' @seealso [`knit_print`] for more details.
31		#'
32		#' @export
33		#' @method knit_print CohortSizeConst
34		#' @rdname knit_print
35		knit_print.CohortSizeConst <- function(
36		x,
37		...,
38		asis = TRUE,
39		label = c("participant", "participants")
40		) {
41	74x	assert_flag(asis)
42
43	72x	label <- h_prepare_labels(label)
44	72x	rv <- paste0(
45	72x	"A constant size of ",
46	72x	x@size,
47		" ",
48	72x	label[ifelse(x@size == 1, 1, 2)],
49	72x	".\n\n"
50		)
51	72x	if (asis) {
52	6x	rv <- knitr::asis_output(rv)
53		}
54	72x	rv
55		}
56
57		#' Render a `CohortSizeRange` Object
58		#'
59		#' @description `r lifecycle::badge("experimental")`
60		#' @param ... passed to `knitr::kable`
61		#' @inherit knit_print.CohortSizeConst return
62		#' @section Usage Notes:
63		#' The default value of `col.names` is `c("Lower", "Upper", "Cohort size")` and
64		#' that of `caption` is `"Defined by the dose to be used in the next cohort"`.
65		#' These values can be overridden by passing `col.names` and `caption` in the
66		#' function call.
67		#' @export
68		#' @method knit_print CohortSizeRange
69		#' @rdname knit_print
70		knit_print.CohortSizeRange <- function(x, ..., asis = TRUE) {
71	47x	assert_flag(asis)
72
73	45x	param <- h_kable_param_default(
74	45x	list(...),
75	45x	col_names = c("Lower", "Upper", "Cohort size"),
76	45x	caption = "Defined by the dose to be used in the next cohort"
77		)
78	45x	x <- tidy(x)
79	45x	param[["x"]] <- x
80	45x	rv <- kableExtra::add_header_above(
81	45x	do.call(knitr::kable, param),
82	45x	c("Dose" = 2, " " = 1)
83		)
84	45x	rv <- paste0(rv, "\n\n")
85
86	45x	if (asis) {
87	12x	rv <- knitr::asis_output(rv)
88		}
89	45x	rv
90		}
91
92		#' Render a `CohortSizeDLT` Object
93		#'
94		#' @description `r lifecycle::badge("experimental")`
95		#' @inherit knit_print.CohortSizeConst return
96		#' @param ... Passed to [knitr::kable()].
97		#'
98		#' @section Usage Notes:
99		#' The by default, the columns are labelled `Lower`, `Upper` and `Cohort size`.
100		#' The table's caption is `Defined by the number of <tox_label[2]> so far observed`.
101		#' These values can be overridden by passing `col.names` and `caption` in the
102		#' function call.
103		#'
104		#' @export
105		#' @method knit_print CohortSizeDLT
106		#' @rdname knit_print
107		knit_print.CohortSizeDLT <- function(
108		x,
109		...,
110		tox_label = "toxicity",
111		asis = TRUE
112		) {
113	42x	assert_flag(asis)
114	40x	tox_label <- h_prepare_labels(tox_label)
115
116	40x	param <- h_kable_param_default(
117	40x	list(...),
118	40x	col_names = c("Lower", "Upper", "Cohort size"),
119	40x	caption = paste0(
120	40x	"Defined by the number of ",
121	40x	tox_label[2],
122	40x	" so far observed"
123		)
124		)
125	40x	param[["x"]] <- tidy(x)
126	40x	headers <- c(2, 1)
127	40x	names(headers) <- c(paste0("No of ", tox_label[2]), " ")
128	40x	rv <- kableExtra::add_header_above(
129	40x	do.call(knitr::kable, param),
130	40x	headers
131		)
132	40x	rv <- paste0(rv, "\n\n")
133
134	40x	if (asis) {
135	9x	rv <- knitr::asis_output(rv)
136		}
137	40x	rv
138		}
139
140		#' Render a `CohortSizeParts` Object
141		#'
142		#' @description `r lifecycle::badge("experimental")`
143		#' @inherit knit_print.CohortSizeConst return
144		#' @inheritSection knit_print.CohortSizeConst Usage Notes
145		#'
146		#' @export
147		#' @method knit_print CohortSizeParts
148		#' @rdname knit_print
149		knit_print.CohortSizeParts <- function(
150		x,
151		...,
152		asis = TRUE,
153		label = c("participant", "participants")
154		) {
155	11x	assert_flag(asis)
156
157	9x	label <- h_prepare_labels(label)
158	9x	rv <- paste0(
159	9x	"A size of ",
160	9x	x@cohort_sizes[1],
161		" ",
162	9x	label[ifelse(x@cohort_sizes[1] == 1, 1, 2)],
163	9x	" in the first part and ",
164	9x	x@cohort_sizes[2],
165		" ",
166	9x	label[ifelse(x@cohort_sizes[2] == 1, 1, 2)],
167	9x	" in the second.\n\n"
168		)
169	9x	if (asis) {
170	6x	rv <- knitr::asis_output(rv)
171		}
172	9x	rv
173		}
174
175		#' Render a `CohortSizeMax` Object
176		#'
177		#' @description `r lifecycle::badge("experimental")`
178		#' @inherit knit_print.CohortSizeConst return
179		#' @param ... passed through to the `knit_print` methods of the constituent
180		#' rules
181		#'
182		#' @export
183		#' @method knit_print CohortSizeMax
184		#' @rdname knit_print
185		knit_print.CohortSizeMax <- function(x, ..., asis = TRUE) {
186	32x	assert_flag(asis)
187
188	30x	params <- list(...)
189	30x	params[["asis"]] <- asis
190	30x	rv <- paste0(
191	30x	"The maximum of the cohort sizes defined in the following rules:",
192	30x	paste0(
193	30x	lapply(
194	30x	x@cohort_sizes,
195	30x	function(x) {
196	60x	knit_print(x, ..., asis = asis)
197		}
198		),
199	30x	collapse = "\n"
200		),
201	30x	"\n\n",
202	30x	paste = "\n"
203		)
204
205	30x	if (asis) {
206	3x	rv <- knitr::asis_output(rv)
207		}
208	30x	rv
209		}
210
211		#' Render a `CohortSizeMin` Object
212		#'
213		#' @description `r lifecycle::badge("experimental")`
214		#' @inherit knit_print.CohortSizeConst return
215		#' @param ... passed through to the `knit_print` methods of the constituent
216		#' rules
217		#'
218		#' @export
219		#' @method knit_print CohortSizeMin
220		#' @rdname knit_print
221		knit_print.CohortSizeMin <- function(x, ..., asis = TRUE) {
222	7x	assert_flag(asis)
223	5x	rv <- paste0(
224	5x	"The minimum of the cohort sizes defined in the following rules:",
225	5x	paste0(
226	5x	lapply(
227	5x	x@cohort_sizes,
228	5x	function(x, ...) {
229	10x	knit_print(x, asis = asis, ...)
230		}
231		),
232	5x	collapse = "\n"
233		),
234	5x	"\n\n",
235	5x	sep = "\n"
236		)
237	5x	if (asis) {
238	3x	rv <- knitr::asis_output(rv)
239		}
240	5x	rv
241		}
242
243		#' Render a `CohortSizeOrdinal` Object
244		#'
245		#' @description `r lifecycle::badge("experimental")`
246		#' @inherit knit_print.CohortSizeConst return
247		#' @param ... passed through to the `knit_print` method of the standard rule
248		#'
249		#' @export
250		#' @method knit_print CohortSizeOrdinal
251		#' @rdname knit_print
252		knit_print.CohortSizeOrdinal <- function(
253		x,
254		...,
255		tox_label = "toxicity",
256		asis = TRUE
257		) {
258	22x	assert_flag(asis)
259	20x	tox_label <- h_prepare_labels(tox_label)
260
261	20x	rv <- paste0(
262	20x	"Based on a ",
263	20x	tox_label[1],
264	20x	" grade of ",
265	20x	x@grade,
266		": ",
267	20x	paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n"),
268	20x	"\n\n",
269	20x	sep = "\n"
270		)
271
272	20x	if (asis) {
273	3x	rv <- knitr::asis_output(rv)
274		}
275	20x	rv
276		}
277
278		#' Render a `CohortSizeRandom` Object
279		#'
280		#' @description `r lifecycle::badge("experimental")`
281		#' @inherit knit_print.CohortSizeConst return
282		#' @inheritSection knit_print.CohortSizeConst Usage Notes
283		#'
284		#' @export
285		#' @method knit_print CohortSizeRandom
286		#' @rdname knit_print
287		knit_print.CohortSizeRandom <- function(
288		x,
289		...,
290		asis = TRUE,
291		label = c("participant", "participants")
292		) {
293	7x	assert_flag(asis)
294
295	5x	label <- h_prepare_labels(label)
296	5x	rv <- paste0(
297	5x	"A random cohort size drawn uniformly between ",
298	5x	x@min_size,
299	5x	" and ",
300	5x	x@max_size,
301		" ",
302	5x	label[2],
303	5x	".\n\n"
304		)
305	5x	if (asis) {
306	3x	rv <- knitr::asis_output(rv)
307		}
308	5x	rv
309		}

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	518x	assert_class(object, "GeneralData")
32	518x	assert_character(where)
33	518x	assert_subset(where, slotNames(object))
34	517x	assert_number(dummy)
35
36	517x	if (object@nObs == 1L) {
37	8x	for (i in where) {
38		# Add dummy value and preserve the class.
39	19x	slot(object, i) <- as(c(slot(object, i), dummy), class(slot(object, i)))
40		}
41		}
42	517x	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	949x	assert_function(model1)
67	949x	assert_function(model2)
68	949x	assert_class(body(model1), "{")
69	948x	assert_class(body(model2), "{")
70
71		# This workaround is needed to avoid bugs related to covr-injected code.
72	948x	if (h_covr_active()) {
73	948x	body(model2) <- h_covr_detrace(body(model2))
74		}
75
76	948x	body2 <- as.list(body(model2))
77	948x	if (length(body2) >= 2) {
78	947x	body1 <- as.list(body(model1))
79	947x	body(model1) <- as.call(c(body1, body2[-1]))
80		}
81	948x	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	511x	assert_class(model, "GeneralModel")
104	511x	assert_class(data, "GeneralData")
105
106	511x	inits <- do.call(model@init, h_slots(data, formalArgs(model@init)))
107	511x	assert_list(inits)
108	510x	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	514x	assert_class(model, "GeneralModel")
129	514x	assert_class(data, "GeneralData")
130	514x	assert_flag(from_prior)
131
132		# 1) Extract variables from `data` as required by `modelspecs`.
133	514x	ms_args_names <- formalArgs(model@modelspecs)
134	514x	ms_args <- if ("from_prior" %in% ms_args_names) {
135	482x	c(
136	482x	h_slots(data, setdiff(ms_args_names, "from_prior")),
137	482x	list(from_prior = from_prior)
138		)
139		} else {
140	32x	h_slots(data, ms_args_names)
141		}
142	514x	modelspecs <- do.call(model@modelspecs, ms_args)
143	514x	assert_list(modelspecs)
144
145		# 2) Extract variables from `data` as required by `datanames`.
146	513x	datanames <- if (from_prior) {
147	42x	model@datanames_prior
148		} else {
149	471x	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	513x	add_where <- setdiff(
155	513x	datanames,
156	513x	c("nObs", "nGrid", "nObsshare", "yshare", "xshare", "Tmax")
157		)
158	513x	data <- h_jags_add_dummy(data, where = add_where)
159
160	513x	data_model <- h_slots(data, datanames)
161	513x	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	555x	assert_function(model)
198	555x	assert_count(digits)
199
200		# This workaround is needed to avoid bugs related to covr-injected code.
201	555x	if (h_covr_active()) {
202	555x	body(model) <- h_covr_detrace(body(model))
203		}
204
205	555x	if (!is.null(file)) {
206	1x	assert_path_for_output(file)
207		} else {
208	554x	dir <- file.path(tempdir(), "R_crmPack")
209		# Don't warn, as the temp dir often exists (which is OK).
210	554x	dir.create(dir, showWarnings = FALSE)
211	554x	file <- tempfile(
212	554x	pattern = "jags_model_fun",
213	554x	tmpdir = dir,
214	554x	fileext = ".txt"
215		)
216		}
217
218		# Replace scientific notation.
219	555x	model_sci_replaced <- h_rapply(
220	555x	x = body(model),
221	555x	fun = h_format_number,
222	555x	classes = c("integer", "numeric"),
223	555x	digits = digits,
224	555x	prefix = "TEMP_NUM_PREF_",
225	555x	suffix = "_TEMP_NUM_SUF"
226		)
227		# Transform `model` body into character vector.
228	555x	model_text <- deparse(model_sci_replaced, control = NULL)
229	555x	model_text <- gsub("\"TEMP_NUM_PREF_\|_TEMP_NUM_SUF\"", "", model_text)
230	555x	model_text <- gsub("%_% ", "", model_text)
231	555x	model_text <- c("model", model_text)
232
233	555x	log_trace("Writting JAGS model function into: %s", file)
234	555x	writeLines(model_text, con = file)
235	555x	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	1369x	assert_class(x, "mcarray")
253
254	1369x	x <- x[,, 1L]
255		# In case that there are multiple parameters in a node.
256	1369x	if (is.matrix(x)) {
257	202x	x <- t(x)
258		}
259	1369x	x
260		}

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	13x	assert_flag(asis)
14
15	11x	rv <- paste0(
16	11x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
17	11x	"Based on a toxicity grade of ",
18	11x	x@grade,
19		": ",
20	11x	paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n")
21		)
22
23	11x	if (asis) {
24	3x	rv <- knitr::asis_output(rv)
25		}
26	11x	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	9x	assert_flag(asis)
42
43	7x	rv <- paste0(
44	7x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
45	7x	"If the ratio of the upper to the lower limit of the posterior 95% credible ",
46	7x	"interval for the probability of toxicity at the target dose (the smaller ",
47	7x	"of the MTD for ",
48	7x	100 * x@prob_target,
49	7x	"% target and GStar) is less than or equal to ",
50	7x	x@target_ratio,
51	7x	".\n\n"
52		)
53
54	7x	if (asis) {
55	3x	rv <- knitr::asis_output(rv)
56		}
57	7x	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	70x	assert_flag(asis)
79	64x	assert_integer(indent, lower = 0)
80
81	64x	if (missing(preamble)) {
82	10x	case_string <- switch(
83	10x	as.character(length(x@stop_list)),
84	10x	`1` = "rule ",
85	10x	"rules "
86		)
87	10x	preamble <- paste0(
88	10x	"If the result of applying the summary function to the following ",
89	10x	case_string,
90	10x	"is `TRUE`:\n"
91		)
92		} else {
93	54x	assert_character(preamble, len = 1, any.missing = FALSE)
94		}
95
96	64x	rules_list <- paste0(
97	64x	lapply(
98	64x	x@stop_list,
99	64x	function(z, indent) {
100	148x	paste0(
101	148x	strrep(" ", indent * 4),
102		"- ",
103	148x	knit_print(z, asis = FALSE, indent = indent + 1L, ...)
104		)
105		},
106	64x	indent = indent
107		),
108	64x	collapse = "\n"
109		)
110	64x	rv <- paste0(
111	64x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
112	64x	preamble,
113	64x	"\n",
114	64x	rules_list,
115	64x	"\n\n"
116		)
117
118	64x	if (asis) {
119	9x	rv <- knitr::asis_output(rv)
120		}
121	64x	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	36x	if (missing(preamble)) {
138	36x	case_string <- switch(
139	36x	as.character(length(x@stop_list)),
140	36x	`1` = c("this ", "rule is "),
141	36x	`2` = c("either of the ", "rules are "),
142	36x	c("any of the ", "rules are ") # this works as default case
143		)
144	36x	preamble <- paste0(
145	36x	"If ",
146	36x	case_string[1],
147	36x	"following ",
148	36x	case_string[2],
149	36x	"`TRUE`:\n"
150		)
151		}
152	36x	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	22x	if (missing(preamble)) {
167	22x	case_string <- switch(
168	22x	as.character(length(x@stop_list)),
169	22x	`1` = c("this ", "rule is "),
170	22x	`2` = c("both of the ", "rules are "),
171	22x	c("all of the ", "rules are ") # this works as default case
172		)
173	22x	preamble <- paste0(
174	22x	"If ",
175	22x	case_string[1],
176	22x	"following ",
177	22x	case_string[2],
178	22x	"`TRUE`:\n"
179		)
180		}
181	22x	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	9x	assert_flag(asis)
203	7x	assert_character(fmt_string, len = 1, any.missing = FALSE)
204	7x	assert_character(tox_label, len = 1, any.missing = FALSE)
205	7x	assert_character(dose_label, len = 1, any.missing = FALSE)
206
207	7x	rv <- paste0(
208	7x	sprintf(
209	7x	fmt_string,
210	7x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
211	7x	dose_label,
212	7x	tox_label,
213	7x	100 * x@prob_target
214		),
215	7x	x@target_ratio,
216	7x	".\n\n"
217		)
218
219	7x	if (asis) {
220	3x	rv <- knitr::asis_output(rv)
221		}
222	7x	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	16x	assert_flag(asis)
245	14x	assert_character(fmt_string, len = 1, any.missing = FALSE)
246	14x	assert_character(biomarker_label, len = 1, any.missing = FALSE)
247
248	14x	rv <- sprintf(
249	14x	fmt_string,
250	14x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
251	14x	dose_label,
252	14x	biomarker_label,
253	14x	x@target[1],
254	14x	x@target[2],
255	14x	ifelse(
256	14x	x@is_relative,
257	14x	paste0(", relative to the maximum value of ", biomarker_label, ","),
258		""
259		),
260	14x	100 * x@prob
261		)
262
263	14x	if (asis) {
264	3x	rv <- knitr::asis_output(rv)
265		}
266	14x	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	9x	assert_flag(asis)
288	7x	assert_character(fmt_string, len = 1, any.missing = FALSE)
289
290	7x	rv <- sprintf(
291	7x	fmt_string,
292	7x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
293	7x	x@a,
294	7x	x@b,
295	7x	tox_label,
296	7x	100 * x@prob
297		)
298
299	7x	if (asis) {
300	3x	rv <- knitr::asis_output(rv)
301		}
302	7x	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	9x	assert_flag(asis)
322	7x	assert_character(fmt_string, len = 1, any.missing = FALSE)
323
324	7x	rv <- sprintf(
325	7x	fmt_string,
326	7x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
327	7x	100 * x@target,
328	7x	100 * x@thresh_cv
329		)
330
331	7x	if (asis) {
332	3x	rv <- knitr::asis_output(rv)
333		}
334	7x	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	9x	assert_flag(asis)
353	7x	assert_character(dose_label, len = 1, any.missing = FALSE)
354	7x	assert_character(tox_label, len = 1, any.missing = FALSE)
355	7x	assert_character(fmt_string, len = 1, any.missing = FALSE)
356
357	7x	rv <- sprintf(
358	7x	fmt_string,
359	7x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
360	7x	tox_label,
361	7x	100 * x@thresh,
362	7x	dose_label,
363	7x	x@prob
364		)
365
366	7x	if (asis) {
367	3x	rv <- knitr::asis_output(rv)
368		}
369	7x	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	9x	rv <- paste0(
386	9x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
387	9x	"If the next best dose is ",
388	9x	dose_label,
389	9x	".\n\n"
390		)
391
392	9x	if (asis) {
393	3x	rv <- knitr::asis_output(rv)
394		}
395	7x	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	9x	x@rule@report_label <- x@report_label
413	9x	knit_print(
414	9x	x@rule,
415		...,
416	9x	dose_label = dose_label,
417	9x	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	68x	assert_flag(asis)
444	64x	assert_character(dose_label, len = 1, any.missing = FALSE)
445	64x	assert_character(tox_label, len = 1, any.missing = FALSE)
446	64x	assert_character(fmt_string, len = 1, any.missing = FALSE)
447
448	64x	rv <- sprintf(
449	64x	fmt_string,
450	64x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
451	64x	tox_label,
452	64x	dose_label,
453	64x	x@target[1],
454	64x	x@target[2],
455	64x	x@prob
456		)
457
458	64x	if (asis) {
459	9x	rv <- knitr::asis_output(rv)
460		}
461	64x	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	48x	assert_flag(asis)
477
478	46x	rv <- paste0(
479	46x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
480	46x	"If ",
481	46x	x@nCohorts,
482	46x	" or more cohorts have been treated.\n\n"
483		)
484	46x	if (asis) {
485	3x	rv <- knitr::asis_output(rv)
486		}
487	46x	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	93x	assert_flag(asis)
505	91x	label <- h_prepare_labels(label)
506
507	91x	rv <- paste0(
508	91x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
509	91x	"If ",
510	91x	x@nPatients,
511	91x	paste0(" or more ", label[2], " have been treated."),
512	91x	"\n\n"
513		)
514	91x	if (asis) {
515	3x	rv <- knitr::asis_output(rv)
516		}
517	91x	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	9x	assert_flag(asis)
537	7x	assert_character(label, len = 1, any.missing = FALSE)
538	7x	assert_character(dose_label, len = 1, any.missing = FALSE)
539
540	7x	rv <- paste0(
541	7x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
542	7x	"If ",
543	7x	x@nPatients,
544	7x	paste0(" or more ", label),
545	7x	ifelse(x@include_backfill, " ", " (excluding backfill cohorts) "),
546	7x	"have been treated ",
547	7x	ifelse(
548	7x	x@percentage == 0,
549	7x	"at ",
550	7x	paste0("within ", x@percentage, "% of ")
551		),
552	7x	dose_label,
553	7x	".\n\n"
554		)
555	7x	if (asis) {
556	3x	rv <- knitr::asis_output(rv)
557		}
558	7x	rv
559		}
560
561		# StoppingCohortsNearDose ----
562
563		#' @description `r lifecycle::badge("experimental")`
564		#' @param asis (`flag`)\cr Not used at present
565		#' @inheritParams knit_print.StoppingTargetProb
566		#' @rdname knit_print
567		#' @export
568		#' @method knit_print StoppingCohortsNearDose
569		knit_print.StoppingCohortsNearDose <- function(
570		x,
571		...,
572		dose_label = "the next best dose",
573		asis = TRUE
574		) {
575	9x	assert_flag(asis)
576	7x	assert_character(dose_label, len = 1, any.missing = FALSE)
577
578	7x	rv <- paste0(
579	7x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
580	7x	"If ",
581	7x	x@nCohorts,
582	7x	" or more cohorts have been treated ",
583	7x	ifelse(
584	7x	x@percentage == 0,
585	7x	"at ",
586	7x	paste0("within ", x@percentage, "% of ")
587		),
588	7x	dose_label,
589	7x	".\n\n"
590		)
591
592	7x	if (asis) {
593	3x	rv <- knitr::asis_output(rv)
594		}
595	7x	rv
596		}
597
598		# StoppingMissingDose ----
599
600		#' @description `r lifecycle::badge("experimental")`
601		#' @param asis (`flag`)\cr Not used at present
602		#' @rdname knit_print
603		#' @export
604		#' @method knit_print StoppingMissingDose
605		knit_print.StoppingMissingDose <- function(
606		x,
607		...,
608		asis = TRUE
609		) {
610	9x	assert_flag(asis)
611
612	7x	rv <- paste0(
613	7x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
614	7x	"If the dose returned by <code>nextBest()</code> is ",
615	7x	"<code>NA</code>, or if the trial includes a placebo dose, the placebo dose.\n\n"
616		)
617
618	7x	if (asis) {
619	3x	rv <- knitr::asis_output(rv)
620		}
621	7x	rv
622		}

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		##' @include helpers.R
2		##' @include Model-class.R
3		NULL
4
5		# Helper functions ----
6
7		#' Get Starting Values for Quantiles Optimization
8		#'
9		#' @param parstart (`numeric` or `NULL`)\cr starting parameter values.
10		#' @param median (`numeric`)\cr median values.
11		#' @param dosegrid (`numeric`)\cr dose grid.
12		#' @param refDose (`number`)\cr reference dose.
13		#' @param logNormal (`flag`)\cr use log-normal prior?
14		#'
15		#' @return Numeric vector of starting values.
16		#' @keywords internal
17		h_get_quantiles_start_values <- function(
18		parstart,
19		median,
20		dosegrid,
21		refDose,
22		logNormal
23		) {
24	12x	if (is.null(parstart)) {
25		# Find approximate means for alpha and slope beta from fitting logistic model to medians.
26	9x	startAlphaBeta <- coef(lm(I(logit(median)) ~ I(log(dosegrid / refDose))))
27
28	9x	c(
29	9x	meanAlpha = unname(startAlphaBeta[1]),
30	9x	meanBeta = unname(
31	9x	if (logNormal) log(startAlphaBeta[2]) else startAlphaBeta[2]
32		),
33	9x	sdAlpha = 1,
34	9x	sdBeta = 1,
35	9x	correlation = 0
36		)
37		} else {
38	3x	parstart
39		}
40		}
41
42		#' Target Function for Quantiles Optimization
43		#'
44		#' @param dosegrid (`numeric`)\cr dose grid.
45		#' @param refDose (`number`)\cr reference dose.
46		#' @param lower (`numeric`)\cr lower quantiles.
47		#' @param median (`numeric`)\cr median quantiles.
48		#' @param upper (`numeric`)\cr upper quantiles.
49		#' @param level (`number`)\cr credible level.
50		#' @param logNormal (`flag`)\cr use log-normal prior?
51		#' @param seed (`count`)\cr random seed.
52		#'
53		#' @return Function that computes target value for optimization.
54		#' @keywords internal
55		h_quantiles_target_function <- function(
56		dosegrid,
57		refDose,
58		lower,
59		median,
60		upper,
61		level,
62		logNormal,
63		seed
64		) {
65	10x	function(param) {
66		# Form the mean vector and covariance matrix
67	3770x	mean <- param[1:2]
68	3770x	cov <- matrix(
69	3770x	c(
70	3770x	param[3]^2,
71	3770x	prod(param[3:5]),
72	3770x	prod(param[3:5]),
73	3770x	param[4]^2
74		),
75	3770x	nrow = 2L,
76	3770x	ncol = 2L
77		)
78
79		# Simulate from the corresponding normal distribution
80	3770x	set.seed(seed)
81	3770x	normalSamples <- mvtnorm::rmvnorm(
82	3770x	n = 1e4L,
83	3770x	mean = mean,
84	3770x	sigma = cov
85		)
86
87		# Extract separate coefficients
88	3770x	alphaSamples <- normalSamples[, 1L]
89	3770x	betaSamples <- if (logNormal) {
90	1823x	exp(normalSamples[, 2L])
91		} else {
92	1947x	normalSamples[, 2L]
93		}
94
95		# Compute resulting quantiles
96	3770x	quants <- matrix(
97	3770x	nrow = length(dosegrid),
98	3770x	ncol = 3L
99		)
100	3770x	colnames(quants) <- c("lower", "median", "upper")
101
102		# Process each dose
103	3770x	for (i in seq_along(dosegrid)) {
104		# Create samples of the probability
105	13270x	probSamples <- plogis(
106	13270x	alphaSamples + betaSamples * log(dosegrid[i] / refDose)
107		)
108
109		# Compute lower, median and upper quantile
110	13270x	quants[i, ] <- quantile(
111	13270x	probSamples,
112	13270x	probs = c((1 - level) / 2, 0.5, (1 + level) / 2)
113		)
114		}
115
116		# Compute the target value
117	3770x	ret <- max(abs(quants - c(lower, median, upper)))
118	3770x	structure(ret, mean = mean, cov = cov, quantiles = quants)
119		}
120		}
121
122		# Quantiles2LogisticNormal ----
123
124		#' Convert Prior Quantiles to Logistic (Log) Normal Model
125		#'
126		#' @description `r lifecycle::badge("stable")`
127		#'
128		#' This function uses generalized simulated annealing to optimize
129		#' a [`LogisticNormal`] model to be as close as possible
130		#' to the given prior quantiles.
131		#'
132		#' @param dosegrid (`numeric`)\cr the dose grid.
133		#' @param refDose (`number`)\cr the reference dose.
134		#' @param lower (`numeric`)\cr the lower quantiles.
135		#' @param median (`numeric`)\cr the medians.
136		#' @param upper (`numeric`)\cr the upper quantiles.
137		#' @param level (`number`)\cr the credible level of the (lower, upper) intervals.
138		#' Default is 0.95.
139		#' @param logNormal (`flag`)\cr use the log-normal prior? If `FALSE` (default),
140		#' the normal prior for the logistic regression coefficients is used.
141		#' @param parstart (`numeric` or `NULL`)\cr starting values for the parameters.
142		#' By default, these are determined from the medians supplied.
143		#' @param parlower (`numeric`)\cr lower bounds on the parameters (intercept alpha
144		#' and the slope beta, the corresponding standard deviations and the correlation).
145		#' @param parupper (`numeric`)\cr upper bounds on the parameters.
146		#' @param seed (`count`)\cr seed for random number generation.
147		#' @param verbose (`flag`)\cr should the function be verbose?
148		#' @param control (`list`)\cr additional options for the optimisation routine,
149		#' see [GenSA::GenSA()] for more details.
150		#'
151		#' @return A list with the best approximating `model`
152		#' ([`LogisticNormal`] or [`LogisticLogNormal`]), the resulting `quantiles`,
153		#' the `required` quantiles and the `distance` to the required quantiles,
154		#' as well as the final `parameters` (which could be used for running the
155		#' algorithm a second time).
156		#'
157		#' @importFrom GenSA GenSA
158		#' @importFrom mvtnorm rmvnorm
159		#' @export
160		Quantiles2LogisticNormal <- function(
161		dosegrid,
162		refDose,
163		lower,
164		median,
165		upper,
166		level = 0.95,
167		logNormal = FALSE,
168		parstart = NULL,
169		parlower = c(-10, -10, 0, 0, -0.95),
170		parupper = c(10, 10, 10, 10, 0.95),
171		seed = 12345,
172		verbose = TRUE,
173		control = list(
174		threshold.stop = 0.01,
175		maxit = 50000,
176		temperature = 50000,
177		max.time = 600
178		)
179		) {
180		# Argument validation
181	9x	assert_numeric(
182	9x	dosegrid,
183	9x	min.len = 1,
184	9x	any.missing = FALSE,
185	9x	sorted = TRUE,
186	9x	unique = TRUE
187		)
188	9x	assert_number(refDose, finite = TRUE)
189	9x	assert_numeric(lower, len = length(dosegrid), any.missing = FALSE)
190	9x	assert_numeric(
191	9x	median,
192	9x	len = length(dosegrid),
193	9x	any.missing = FALSE,
194	9x	sorted = TRUE
195		)
196	9x	assert_numeric(upper, len = length(dosegrid), any.missing = FALSE)
197	9x	assert_probability(level, bounds_closed = FALSE)
198	9x	assert_flag(logNormal)
199	9x	assert_numeric(parstart, len = 5, null.ok = TRUE)
200	9x	assert_numeric(parlower, len = 5, any.missing = FALSE)
201	9x	assert_numeric(parupper, len = 5, any.missing = FALSE)
202	9x	assert_count(seed, positive = TRUE)
203	9x	assert_flag(verbose)
204	9x	assert_list(control)
205
206		# Additional validation
207	9x	assert_true(all(lower < median))
208	9x	assert_true(all(median < upper))
209	9x	assert_true(all(parlower < parupper))
210	9x	if (!is.null(parstart)) {
211	2x	assert_true(all(parlower < parstart))
212	2x	assert_true(all(parstart < parupper))
213		}
214
215	9x	nDoses <- length(dosegrid)
216	9x	control$verbose <- verbose
217
218	9x	startValues <- h_get_quantiles_start_values(
219	9x	parstart = parstart,
220	9x	median = median,
221	9x	dosegrid = dosegrid,
222	9x	refDose = refDose,
223	9x	logNormal = logNormal
224		)
225
226	9x	target <- h_quantiles_target_function(
227	9x	dosegrid = dosegrid,
228	9x	refDose = refDose,
229	9x	lower = lower,
230	9x	median = median,
231	9x	upper = upper,
232	9x	level = level,
233	9x	logNormal = logNormal,
234	9x	seed = seed
235		)
236
237	9x	set.seed(seed)
238		# Optimize the target function
239	9x	genSAres <- GenSA::GenSA(
240	9x	par = startValues,
241	9x	fn = target,
242	9x	lower = parlower,
243	9x	upper = parupper,
244	9x	control = control
245		)
246	9x	distance <- genSAres$value
247	9x	pars <- genSAres$par
248	9x	targetRes <- target(pars)
249
250		# Construct the model
251	9x	model <- if (logNormal) {
252	4x	LogisticLogNormal(
253	4x	mean = attr(targetRes, "mean"),
254	4x	cov = attr(targetRes, "cov"),
255	4x	ref_dose = refDose
256		)
257		} else {
258	5x	LogisticNormal(
259	5x	mean = attr(targetRes, "mean"),
260	5x	cov = attr(targetRes, "cov"),
261	5x	ref_dose = refDose
262		)
263		}
264
265	9x	list(
266	9x	model = model,
267	9x	parameters = pars,
268	9x	quantiles = attr(targetRes, "quantiles"),
269	9x	required = cbind(lower, median, upper),
270	9x	distance = distance
271		)
272		}
273
274		#' Helper for Minimal Informative Unimodal Beta Distribution
275		#'
276		#' As defined in \insertCite{NeuenschwanderBransonGsponer2008;textual}{crmPack}, this function
277		#' computes the parameters of the minimal informative unimodal beta distribution, given the
278		#' request that the p-quantile should be q, i.e. `X ~ Be(a, b)` with
279		#' `Pr(X <= q) = p`.
280		#'
281		#' @param p (`number`)\cr the probability.
282		#' @param q (`number`)\cr the quantile.
283		#' @return A list with the two resulting beta parameters `a` and `b`.
284		#'
285		#' @keywords internal
286		#' @references
287		#' \insertAllCited{}
288		h_get_min_inf_beta <- function(p, q) {
289	14x	assert_probability(p, bounds_closed = FALSE)
290	14x	assert_probability(q, bounds_closed = FALSE)
291
292	14x	if (q > p) {
293	5x	list(
294	5x	a = log(p) / log(q),
295	5x	b = 1
296		)
297		} else {
298	9x	list(
299	9x	a = 1,
300	9x	b = log(1 - p) / log(1 - q)
301		)
302		}
303		}
304
305		# MinimalInformative ----
306
307		#' Construct a Minimally Informative Prior
308		#'
309		#' @description `r lifecycle::badge("stable")`
310		#'
311		#' This function constructs a minimally informative prior, which is captured in
312		#' a [`LogisticNormal`] (or [`LogisticLogNormal`]) object.
313		#'
314		#' Based on the proposal by \insertCite{NeuenschwanderBransonGsponer2008;textual}{crmPack},
315		#' a minimally informative prior distribution is constructed. The
316		#' required key input is the minimum (\eqn{d_{1}} in the notation of the
317		#' Appendix A.1 of that paper) and the maximum value (\eqn{d_{J}}) of the dose
318		#' grid supplied to this function. Then `threshmin` is the probability
319		#' threshold \eqn{q_{1}}, such that any probability of DLT larger than
320		#' \eqn{q_{1}} has only 5% probability. Therefore \eqn{q_{1}} is the 95%
321		#' quantile of the beta distribution and hence \eqn{p_{1} = 0.95}. Likewise,
322		#' `threshmax` is the probability threshold \eqn{q_{J}}, such that any
323		#' probability of DLT smaller than \eqn{q_{J}} has only 5% probability
324		#' (\eqn{p_{J} = 0.05}). The probabilities \eqn{1 - p_{1}} and \eqn{p_{J}} can be
325		#' controlled with the arguments `probmin` and `probmax`, respectively.
326		#' Subsequently, for all doses supplied in the
327		#' `dosegrid` argument, beta distributions are set up from the assumption
328		#' that the prior medians are linear in log-dose on the logit scale, and
329		#' [Quantiles2LogisticNormal()] is used to transform the resulting
330		#' quantiles into an approximating [`LogisticNormal`] (or
331		#' [`LogisticLogNormal`]) model. Note that the reference dose
332		#' is not required for these computations.
333		#'
334		#' @param dosegrid (`numeric`)\cr the dose grid.
335		#' @param refDose (`number`)\cr the reference dose.
336		#' @param threshmin (`number`)\cr any toxicity probability above this threshold
337		#' would be very unlikely (see `probmin`) at the minimum dose.
338		#' @param threshmax (`number`)\cr any toxicity probability below this threshold
339		#' would be very unlikely (see `probmax`) at the maximum dose.
340		#' @param probmin (`number`)\cr the prior probability of exceeding `threshmin`
341		#' at the minimum dose.
342		#' @param probmax (`number`)\cr the prior probability of being below `threshmax`
343		#' at the maximum dose.
344		#' @param ... additional arguments for computations, see
345		#' [Quantiles2LogisticNormal()], e.g. `refDose` and
346		#' `logNormal=TRUE` to obtain a minimal informative log normal prior.
347		#'
348		#' @return See [Quantiles2LogisticNormal()].
349		#'
350		#' @example examples/MinimalInformative.R
351		#' @export
352		#' @references
353		#' \insertAllCited{}
354		MinimalInformative <- function(
355		dosegrid,
356		refDose,
357		threshmin = 0.2,
358		threshmax = 0.3,
359		probmin = 0.05,
360		probmax = 0.05,
361		...
362		) {
363		# Argument validation
364	2x	assert_numeric(
365	2x	dosegrid,
366	2x	min.len = 1,
367	2x	any.missing = FALSE,
368	2x	sorted = TRUE,
369	2x	unique = TRUE
370		)
371	2x	assert_number(refDose, finite = TRUE)
372	2x	assert_probability(threshmin, bounds_closed = FALSE)
373	2x	assert_probability(threshmax, bounds_closed = FALSE)
374	2x	assert_probability(probmin, bounds_closed = FALSE)
375	2x	assert_probability(probmax, bounds_closed = FALSE)
376
377	2x	nDoses <- length(dosegrid)
378	2x	xmin <- dosegrid[1]
379	2x	xmax <- dosegrid[nDoses]
380
381		# Derive the beta distributions at the lowest and highest dose
382	2x	betaAtMin <- h_get_min_inf_beta(
383	2x	q = threshmin,
384	2x	p = 1 - probmin
385		)
386	2x	betaAtMax <- h_get_min_inf_beta(
387	2x	q = threshmax,
388	2x	p = probmax
389		)
390
391		# Get the medians of those beta distributions
392	2x	medianMin <- with(betaAtMin, qbeta(p = 0.5, a, b))
393	2x	medianMax <- with(betaAtMax, qbeta(p = 0.5, a, b))
394
395		# Determine the medians of all beta distributions
396	2x	beta <- (logit(medianMax) - logit(medianMin)) / (log(xmax) - log(xmin))
397	2x	alpha <- logit(medianMax) - beta * log(xmax / refDose)
398	2x	medianDosegrid <- plogis(alpha + beta * log(dosegrid / refDose))
399
400		# Calculate 95% credible interval bounds (lower and upper) for all doses
401	2x	lower <- upper <- dosegrid
402	2x	for (i in seq_along(dosegrid)) {
403		# Get minimal informative beta distribution
404	7x	thisMinBeta <- h_get_min_inf_beta(
405	7x	p = 0.5,
406	7x	q = medianDosegrid[i]
407		)
408
409		# Derive required quantiles
410	7x	lower[i] <- with(thisMinBeta, qbeta(p = 0.025, a, b))
411	7x	upper[i] <- with(thisMinBeta, qbeta(p = 0.975, a, b))
412		}
413
414		# Transform quantiles to LogisticNormal model
415	2x	Quantiles2LogisticNormal(
416	2x	dosegrid = dosegrid,
417	2x	refDose = refDose,
418	2x	lower = lower,
419	2x	median = medianDosegrid,
420	2x	upper = upper,
421	2x	level = 0.95,
422		...
423		)
424		}
425
426		# nolint end

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	23x	assert_flag(asis)
22	21x	assert_character(target_label, len = 1, any.missing = FALSE)
23
24	21x	tox_label <- h_prepare_labels(tox_label)
25		# Execute
26	21x	rv <- paste0(
27	21x	"The dose level recommended for the next cohort will be selected as follows:\n\n",
28	21x	"- First, ",
29	21x	target_label,
30	21x	" of the posterior distribution of ",
31	21x	tox_label[1],
32	21x	" will be calculated for all dose levels that are eligible according to the ",
33	21x	" Increments rule.\n",
34	21x	"- Next, the \"target dose\" (which may not be part of the dose grid) for which ",
35	21x	target_label,
36	21x	" of the posterior distribution of ",
37	21x	tox_label[1],
38	21x	" is exactly equal to the target rate of ",
39	21x	x@target,
40	21x	" will be determined.\n",
41	21x	"- Finally, the dose level whose absolute distance from the target dose ",
42	21x	"is smallest will be selected as the recommended dose for the next cohort\n\n"
43		)
44
45	21x	if (asis) {
46	6x	rv <- knitr::asis_output(rv)
47		}
48	21x	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	37x	assert_flag(asis)
66	35x	assert_character(tox_label, max.len = 2, any.missing = FALSE)
67
68		# Execute
69	35x	rv <- paste0(
70	35x	"The dose recommended for the next cohort will be chosen in the following ",
71	35x	"way. First, doses that are ineligible according to the increments rule ",
72	35x	"will be discarded. Next, any dose for which the mean posterior probability of ",
73	35x	tox_label,
74	35x	" being in the overdose range - (",
75	35x	x@overdose[1],
76		", ",
77	35x	x@overdose[2],
78	35x	"] - is ",
79	35x	x@max_overdose_prob,
80	35x	" or more will also be discarded. Finally, the dose amongst those remaining ",
81	35x	"which has the highest chance that the mean posterior probability of ",
82	35x	tox_label,
83	35x	" is in the target ",
84	35x	tox_label,
85	35x	" range of ",
86	35x	x@target[1],
87	35x	" to ",
88	35x	x@target[2],
89	35x	" (inclusive) will be selected.\n\n"
90		)
91
92	35x	if (asis) {
93	3x	rv <- knitr::asis_output(rv)
94		}
95	35x	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	16x	assert_flag(asis)
125
126		# Prepare
127	14x	tox_label <- h_prepare_labels(tox_label)
128	14x	label <- h_prepare_labels(label)
129
130		# Execute
131	14x	rv <- paste0(
132	14x	"The dose recommended for the next cohort will be chosen using the \"Three ",
133	14x	"Plus Three\" rule.\n\n- If no ",
134	14x	tox_label[2],
135	14x	" have been reported at the current dose level, escalate by one dose level.\n",
136	14x	"- If the observed ",
137	14x	tox_label[1],
138	14x	" rate at the current dose level is exactly 1/3 and no more than three ",
139	14x	label[2],
140	14x	" treated at the current dose level are evaluable, remain at the current ",
141	14x	"dose level.\n",
142	14x	"- Otherwise, recommend that the trial stops and identify the MTD as dose ",
143	14x	"level immediately below the current one.\n\n"
144		)
145
146	14x	if (asis) {
147	3x	rv <- knitr::asis_output(rv)
148		}
149	14x	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	16x	assert_flag(asis)
171	14x	assert_character(tox_label, len = 1, any.missing = FALSE)
172	14x	assert_character(biomarker_label, len = 1, any.missing = FALSE)
173	14x	assert_character(biomarker_units, len = 1, any.missing = FALSE)
174
175	14x	rv <- paste0(
176	14x	"The dose recommended for the next cohort will be chosen in the following ",
177	14x	"way. First, doses that are ineligible according to the increments rule ",
178	14x	"will be discarded. Next, any dose for which the mean posterior probability of ",
179	14x	tox_label,
180	14x	" being in the overdose range - (",
181	14x	x@overdose[1],
182		", ",
183	14x	x@overdose[2],
184	14x	"] - is ",
185	14x	x@max_overdose_prob,
186	14x	" or more will also be discarded. Finally, the dose amongst those remaining ",
187	14x	"which has the highest chance that the mean posterior probability that ",
188	14x	biomarker_label,
189	14x	" is in the target range for ",
190	14x	biomarker_label,
191	14x	", which is ",
192	14x	x@target[1],
193	14x	ifelse(
194	14x	x@target_relative,
195		"",
196	14x	stringr::str_squish(paste0(" ", biomarker_units))
197		),
198	14x	" to ",
199	14x	x@target[2],
200	14x	ifelse(
201	14x	x@target_relative,
202		"",
203	14x	stringr::str_squish(paste0(" ", biomarker_units))
204		),
205	14x	" (inclusive),",
206	14x	ifelse(
207	14x	x@target_relative,
208	14x	paste0(" of the maximum ", biomarker_label, " value"),
209		""
210		),
211	14x	" will be selected, provided that this probability exceeds ",
212	14x	x@target_thresh,
213	14x	". If no dose meets this threshold, then the highest eligible dose will ",
214	14x	"be selected.\n\n"
215		)
216
217	14x	if (asis) {
218	3x	rv <- knitr::asis_output(rv)
219		}
220	14x	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	9x	assert_flag(asis)
238	7x	assert_character(tox_label, len = 1, any.missing = FALSE)
239
240		# Execute
241	7x	rv <- paste0(
242	7x	"The dose recommended for the next cohort will be the one which is both ",
243	7x	"eligible and which has the smallest absolute difference between ",
244	7x	"its mean posterior estimate of the probability of ",
245	7x	tox_label,
246	7x	" and the target ",
247	7x	tox_label,
248	7x	" rate [",
249	7x	x@target,
250	7x	"].\n\n"
251		)
252
253	7x	if (asis) {
254	3x	rv <- knitr::asis_output(rv)
255		}
256	7x	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	9x	assert_flag(asis)
281	7x	assert_character(tox_label, len = 1, any.missing = FALSE)
282	7x	assert_character(citation_text, len = 1, any.missing = FALSE)
283	7x	assert_character(citation_link, len = 1, any.missing = FALSE)
284
285		# Execute
286	7x	rv <- paste0(
287	7x	"The recommended dose for the next cohort will be chosen using the ",
288	7x	"complex infinite bounds penalisation (CIBP) criterion of ",
289		"[",
290	7x	citation_text,
291		"]",
292	7x	ifelse(nchar(citation_link) > 0, paste0("(", citation_link, ")"), ""),
293	7x	". Let\n\n",
294	7x	"$$ \\delta(\\hat{p}_d, \\gamma) = \\frac{(\\hat{p}_d - \\gamma)^2}",
295	7x	"{\\hat{p}_d^a \\cdot (1 - \\hat{p}_d)^{2 - a}} $$\n\n",
296	7x	"where a is the non-centrality parameter with a value of ",
297	7x	x@asymmetry,
298	7x	", γ is the target ",
299	7x	tox_label,
300	7x	" rate with a value of ",
301	7x	x@target,
302	7x	" and $\\hat{p}_d$ is the mean posterior estimate of the probability of ",
303	7x	tox_label,
304	7x	" at dose level d.\n\n",
305	7x	"The recommended dose for the next cohort will be ",
306	7x	"the value of d that minimises $\\delta(\\hat{p}_d, \\gamma)$.\n\n"
307		)
308
309	7x	if (asis) {
310	3x	rv <- knitr::asis_output(rv)
311		}
312	7x	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	16x	assert_flag(asis)
330	14x	assert_character(tox_label, len = 1, any.missing = FALSE)
331
332		# Execute
333	14x	rv <- paste0(
334	14x	"The dose recommended for the next cohort will be the one which is both ",
335	14x	"eligible and which is the highest dose in the dose grid strictly less than ",
336	14x	"the dose (which may not be in the dose grid) that has a posterior plug-in ",
337	14x	"estimate of the probability of ",
338	14x	tox_label,
339	14x	" exactly equal to the target ",
340	14x	tox_label,
341	14x	" rate, either during [",
342	14x	x@prob_target_drt,
343	14x	"] or at the end of the trial [",
344	14x	x@prob_target_eot,
345	14x	"].\n\n"
346		)
347
348	14x	if (asis) {
349	3x	rv <- knitr::asis_output(rv)
350		}
351	14x	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	16x	assert_flag(asis)
369	14x	assert_character(tox_label, len = 1, any.missing = FALSE)
370
371		# Execute
372	14x	rv <- paste0(
373	14x	"The dose recommended for the next cohort will be the one which is closest to ",
374	14x	"Gstar, the dose that maximises the gain for probability of ",
375	14x	tox_label,
376	14x	" exactly equal to the target ",
377	14x	tox_label,
378	14x	" rate, either during [",
379	14x	x@prob_target_drt,
380	14x	"] or at the end of the trial [",
381	14x	x@prob_target_eot,
382	14x	"].\n\n"
383		)
384
385	14x	if (asis) {
386	3x	rv <- knitr::asis_output(rv)
387		}
388	14x	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	9x	assert_flag(asis)
406	7x	assert_character(tox_label, len = 1, any.missing = FALSE)
407
408		# Execute
409	7x	rv <- paste0(
410	7x	"The dose recommended for the next cohort will be the dose level with ",
411	7x	"the highest probability of being the highest dose with an estimated ",
412	7x	"probability of ",
413	7x	tox_label,
414	7x	" less than or equal to ",
415	7x	x@target,
416	7x	".\n\n"
417		)
418
419	7x	if (asis) {
420	3x	rv <- knitr::asis_output(rv)
421		}
422	7x	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	9x	assert_flag(asis)
440	7x	assert_character(tox_label, len = 1, any.missing = FALSE)
441
442		# Execute
443	7x	rv <- paste0(
444	7x	"The dose recommended for the next cohort will be the dose level with ",
445	7x	"the highest probability of being the highest dose with an estimated ",
446	7x	"probability of ",
447	7x	tox_label,
448	7x	" closest to ",
449	7x	x@target,
450	7x	".\n\n"
451		)
452
453	7x	if (asis) {
454	3x	rv <- knitr::asis_output(rv)
455		}
456	7x	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	9x	assert_flag(asis)
477	7x	assert_character(tox_label, len = 1, any.missing = FALSE)
478
479		# Execute
480	7x	param <- list(...)
481	7x	param[["x"]] <- x %>%
482	7x	tidy() %>%
483	7x	dplyr::select(-MaxOverdoseProb)
484	7x	param[["col.names"]] <- c("Range", "Lower", "Upper", "Loss Coefficient")
485	7x	rv <- paste0(
486	7x	"The dose recommended for the next cohort will be chosen in the following ",
487	7x	"way:\n\n- First, the chance that the probability of ",
488	7x	tox_label,
489	7x	" falls into each of the underdose, target ",
490	7x	ifelse(
491	7x	any(x@unacceptable != c(1, 1)),
492	7x	", overdose and unacceptable",
493	7x	" and overdose"
494		),
495	7x	" dose ranges is calculated for element of the dose grid.\n",
496	7x	"- Next, the loss associated with each dose is calculated by multiplying ",
497	7x	"these probabilities by the corresponding loss coefficient and summing the result.\n",
498	7x	"- Then ineligible doses, and those with a probability of being in the ",
499	7x	ifelse(
500	7x	length(x@losses) == 3,
501	7x	"overdose range",
502	7x	"overdose or unaccaptable ranges"
503		),
504	7x	" that is greater than ",
505	7x	x@max_overdose_prob,
506	7x	", are discarded.\n",
507	7x	"- Finally, the dose level with the smallest loss is selected as the ",
508	7x	"recommended dose for the next cohort.\n\n",
509	7x	ifelse(
510	7x	toupper(tox_label) == tox_label,
511	7x	tox_label,
512	7x	stringr::str_to_sentence(tox_label)
513		),
514	7x	" ranges and loss coefficients are given in the following table:\n\n",
515	7x	paste((do.call(knitr::kable, param)) %>% format_func(), collapse = "\n"),
516	7x	"\n\n"
517		)
518
519	7x	if (asis) {
520	3x	rv <- knitr::asis_output(rv)
521		}
522	7x	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	14x	assert_flag(asis)
540	12x	assert_character(tox_label, len = 1, any.missing = FALSE)
541
542		# Execute
543	12x	rv <- paste0(
544	12x	"The dose recommended for the next cohort will be the one which is both ",
545	12x	"eligible and which is the highest dose in the dose grid strictly less than ",
546	12x	"the dose (which may not be in the dose grid) that has a full Bayes posterior ",
547	12x	"estimate of the probability of ",
548	12x	tox_label,
549	12x	" exactly equal to the target ",
550	12x	tox_label,
551	12x	" rate, either during [",
552	12x	x@prob_target_drt,
553	12x	"] or at the end of the trial [",
554	12x	x@prob_target_eot,
555	12x	"].\n\n"
556		)
557
558	12x	if (asis) {
559	3x	rv <- knitr::asis_output(rv)
560		}
561	12x	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	16x	assert_flag(asis)
580	14x	assert_character(tox_label, len = 1, any.missing = FALSE)
581
582		# Execute
583	14x	rv <- paste0(
584	14x	"The dose recommended for the next cohort will be the one which is closest to ",
585	14x	"Gstar, the dose for which the full Bayes posterior estimate of the probability of ",
586	14x	tox_label,
587	14x	" maximises the gain relative to the target ",
588	14x	tox_label,
589	14x	" rate, either during [",
590	14x	x@prob_target_drt,
591	14x	"] or at the end of the trial [",
592	14x	x@prob_target_eot,
593	14x	"].\n\n"
594		)
595
596	14x	if (asis) {
597	3x	rv <- knitr::asis_output(rv)
598		}
599	14x	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	20x	assert_flag(asis)
616	18x	assert_character(tox_label, max.len = 2, any.missing = FALSE)
617
618	18x	tox_label <- h_prepare_labels(tox_label)
619	18x	rv <- paste0(
620	18x	"Based on a ",
621	18x	tox_label[1],
622	18x	" grade of ",
623	18x	x@grade,
624		": ",
625	18x	paste0(
626	18x	knit_print(x@rule, asis = asis, tox_label = tox_label, ...),
627	18x	collapse = "\n"
628		),
629	18x	"\n\n"
630		)
631
632	18x	if (asis) {
633	3x	rv <- knitr::asis_output(rv)
634		}
635	18x	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	150x	assert_numeric(
15	150x	grid,
16	150x	lower = 0,
17	150x	min.len = 2,
18	150x	unique = TRUE,
19	150x	finite = TRUE,
20	150x	sorted = TRUE,
21	150x	any.missing = FALSE
22		)
23	150x	assert_character(units, len = 1)
24
25	150x	n <- length(grid)
26	150x	units <- h_prepare_units(units)
27	150x	formattedGrid <- if (is.na(fmt)) {
28	148x	as.character(grid)
29		} else {
30	2x	sprintf(fmt, grid)
31		}
32	150x	paste0(
33	150x	paste(
34	150x	lapply(
35	150x	formattedGrid[1:(n - 1)],
36	150x	paste0,
37	150x	sep = units
38		),
39	150x	collapse = ", "
40		),
41	150x	" and ",
42	150x	formattedGrid[n],
43	150x	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	140x	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	58x	if (!("col.names" %in% names(param))) {
65	58x	if (summarise == "none") {
66	50x	param[["col.names"]] <- c("ID", "Cohort", "Dose", "DLT?")
67	8x	} else if (summarise == "dose") {
68	4x	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
69		} else {
70	4x	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
71		}
72		}
73	58x	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	18x	if (!("col.names" %in% names(param))) {
81	18x	if (summarise == "none") {
82	14x	param[["col.names"]] <- c(
83	14x	"ID",
84	14x	"Cohort",
85	14x	"Dose",
86	14x	"Tox",
87	14x	"U",
88	14x	"T0",
89	14x	"TMax"
90		)
91	4x	} else if (summarise == "dose") {
92	2x	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
93		} else {
94	2x	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
95		}
96		}
97	18x	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	11x	if (!("col.names" %in% names(param))) {
105	11x	if (summarise == "none") {
106	7x	param[["col.names"]] <- c("ID", "Cohort", "Dose", "Group", "Tox")
107	4x	} else if (summarise == "dose") {
108	2x	param[["col.names"]] <- c("Dose", "Group", "Evaluable", "With Toxicities")
109		} else {
110	2x	param[["col.names"]] <- c(
111	2x	"Cohort",
112	2x	"Group",
113	2x	"Evaluable",
114	2x	"With Toxicities"
115		)
116		}
117		}
118	11x	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	5x	if (!("col.names" %in% names(param))) {
126	5x	if (summarise == "none") {
127	5x	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	5x	param
135		}
136
137		#' @description `r lifecycle::badge("experimental")`
138		#' @noRd
139		h_knit_print_set_headers.DataOrdinal <- function(x, param, summarise, ...) {
140	16x	if (!("col.names" %in% names(param))) {
141	16x	if (summarise == "none") {
142	16x	param[["col.names"]] <- c(
143	16x	"ID",
144	16x	"Cohort",
145	16x	"Dose",
146	16x	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	16x	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	32x	if (!("col.names" %in% names(param))) {
162	32x	if (summarise == "none") {
163	28x	param[["col.names"]] <- c("ID", "Cohort", "Dose", "Tox", "W")
164	4x	} else if (summarise == "dose") {
165	2x	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
166		} else {
167	2x	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
168		}
169		}
170	32x	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	120x	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	50x	x %>%
199	50x	tidy() %>%
200	50x	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	5x	x %>%
208	5x	tidy() %>%
209	5x	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	16x	x %>%
217	16x	tidy() %>%
218	16x	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	14x	x %>%
226	14x	tidy() %>%
227	14x	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	7x	x %>%
235	7x	tidy() %>%
236	7x	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	28x	x %>%
244	28x	tidy() %>%
245	28x	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	20x	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	16x	xTidy <- x %>% tidy()
267	16x	xTidy <- xTidy %>%
268	16x	dplyr::group_by(.data[[stringr::str_to_title(summarise)]]) %>%
269	16x	dplyr::summarise(
270	16x	N = dplyr::n(),
271	16x	ToxCount = sum(Tox)
272		)
273	16x	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	16x	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	4x	xTidy <- x %>% tidy()
318	4x	xTidy <- xTidy %>%
319	4x	dplyr::group_by(.data[[stringr::str_to_title(summarise)]], .data$Group) %>%
320	4x	dplyr::summarise(
321	4x	N = dplyr::n(),
322	4x	ToxCount = sum(Tox)
323		)
324	4x	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	4x	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	154x	assert_flag(asis)
377	140x	assert_flag(full_grid)
378	140x	assert_function(format_func)
379	140x	summarise <- match.arg(summarise)
380	140x	summarize <- match.arg(summarize)
381
382	140x	if (is.na(summarise) \|\| is.null(summarise)) {
383	!	summarise <- summarize
384		}
385	140x	assert_choice(summarise, c("none", "dose", "cohort"))
386		# Initialise
387	140x	label <- h_prepare_labels(label)
388	140x	param <- list(...)
389
390		# Execute
391	140x	param <- h_knit_print_set_headers(x, param, summarise, ...)
392	140x	if (summarise == "none") {
393	120x	if (!("caption" %in% names(param))) {
394	120x	param[["caption"]] <- paste("Evaluable", label[2], "to-date")
395		}
396	120x	xTidy <- h_knit_print_select_columns(x)
397		} else {
398	20x	xTidy <- h_knit_print_summarise(x, summarise, full_grid)
399	20x	if (!("caption" %in% names(param))) {
400	20x	param[["caption"]] <- paste0("Summarised by ", summarise)
401		}
402		}
403	140x	param[["x"]] <- xTidy
404	140x	rv <- if (length(x@x) > 0) {
405	65x	paste((do.call(knitr::kable, param)) %>% format_func(), collapse = "\n")
406		} else {
407	75x	paste("No", label[2], "are yet evaluable.\n\n")
408		}
409	140x	rv <- paste0(
410	140x	rv,
411	140x	paste0(
412	140x	"\n\nThe dose grid is ",
413	140x	h_get_formatted_dosegrid(
414	140x	grid = x@doseGrid,
415	140x	units = units,
416		...
417		),
418		""
419		),
420	140x	"\n\n",
421	140x	collpase = "\n"
422		)
423	140x	if (asis) {
424	51x	rv <- knitr::asis_output(rv)
425		}
426	140x	rv
427		}
428
429		#' Used to obtain expected format.
430		#' @keywords internal
431		h_knit_format_func <- function(x) {
432	71x	kableExtra::kable_styling(
433	71x	x,
434	71x	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	7x	rv <- NextMethod()
453	5x	rv <- paste0(
454	5x	rv,
455	5x	paste0(
456	5x	"\n\nThe part 1 ladder is ",
457	5x	h_get_formatted_dosegrid(x@part1Ladder, units)
458		),
459	5x	paste0("\n\nThe next part is Part ", x@nextPart, ".\n\n")
460		)
461	5x	if (asis) {
462	3x	rv <- knitr::asis_output(rv)
463		}
464	5x	rv
465		}

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	3x	v <- Validate()
21
22	3x	nSims <- length(object@data)
23
24	3x	v$check(
25	3x	all(sapply(object@data, is, "Data")),
26	3x	"all data elements must be Data objects"
27		)
28	3x	v$check(
29	3x	identical(length(object@doses), nSims),
30	3x	"doses must have same length as the data list"
31		)
32
33	3x	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	5x	v <- Validate()
42
43	5x	nSims <- length(object@data)
44
45	5x	v$check(
46	5x	identical(length(object@fit), nSims),
47	5x	"fit must have same length as data"
48		)
49	5x	v$check(
50	5x	identical(length(object@stop_reasons), nSims),
51	5x	"stop_reasons must have same length as data"
52		)
53
54	5x	v$check(
55	5x	checkmate::test_matrix(
56	5x	object@stop_report,
57	5x	mode = "logical",
58	5x	nrows = nSims,
59	5x	min.cols = 1,
60	5x	any.missing = FALSE
61		),
62	5x	"stop_report must be a matrix of mode logical in which the number of rows
63	5x	equals the number of simulations and which must not contain any missing values"
64		)
65
66	5x	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	4x	v <- Validate()
74
75	4x	nSims <- length(object@data)
76
77	4x	v$check(
78	4x	identical(length(object@fit_biomarker), nSims),
79	4x	"fit_biomarker list has to have same length as data"
80		)
81	4x	v$check(
82	4x	identical(length(object@rho_est), nSims),
83	4x	"rho_est vector has to have same length as data"
84		)
85	4x	v$check(
86	4x	identical(length(object@sigma2w_est), nSims),
87	4x	"sigma2w_est has to have same length as data"
88		)
89
90	4x	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	2x	v <- Validate()
116
117	2x	nSims <- length(object@data)
118	2x	v$check(
119	2x	identical(length(object@stop_reasons), nSims),
120	2x	"stopReasons must have same length as data"
121		)
122
123	2x	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	2x	v <- Validate()
133	2x	nSims <- length(object@data)
134	2x	v$check(
135	2x	identical(length(object@sigma2_est), nSims),
136	2x	"sigma2_est has to have same length as data"
137		)
138	2x	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	2x	v <- Validate()
147	2x	nSims <- length(object@data)
148	2x	v$check(
149	2x	identical(length(object@sigma2_beta_w_est), nSims),
150	2x	"sigma2_beta_w_est has to have same length as data"
151		)
152	2x	v$result()
153		}
154
155		#' @describeIn v_general_simulations validates that the [`DASimulations`] object
156		#' contains valid `trial_duration` the vector of trial duration values for all
157		#' simulations.
158
159		v_da_simulations <- function(object) {
160	2x	v <- Validate()
161
162	2x	nSims <- length(object@data)
163
164	2x	v$check(
165	2x	identical(length(object@trial_duration), nSims),
166	2x	"trial_duration vector has to have same length as data"
167		)
168
169	2x	v$result()
170		}

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	11275x	assert_numeric(x)
170	11274x	assert_logical(bounds_closed, min.len = 1, max.len = 2, any.missing = FALSE)
171	11274x	assert_number(len, null.ok = TRUE)
172	11274x	assert_flag(sorted)
173
174	11274x	result <- check_numeric(
175	11274x	x,
176	11274x	finite = TRUE,
177	11274x	any.missing = FALSE,
178	11274x	len = len,
179	11274x	unique = unique,
180	11274x	sorted = sorted
181		)
182
183	11274x	if (isTRUE(result)) {
184	11195x	in_bounds <- all(h_in_range(
185	11195x	x,
186	11195x	range = c(0L, 1L),
187	11195x	bounds_closed = bounds_closed
188		))
189	11195x	if (!in_bounds) {
190	145x	result <- paste(
191	145x	"Probability must be within",
192	145x	ifelse(bounds_closed[1], "[0,", "(0,"),
193	145x	ifelse(tail(bounds_closed, 1), "1]", "1)"),
194	145x	"bounds but it is not"
195		)
196		}
197		}
198
199	11274x	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	5968x	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	996x	check_probabilities(
282	996x	x = x,
283	996x	bounds_closed = bounds_closed,
284	996x	len = 2,
285	996x	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	48448x	x_len <- length(x)
332	48448x	assert_true(x_len >= 1L)
333	48447x	assert_count(len)
334
335	48443x	if (x_len == 1L \|\| len == 1L \|\| x_len == len) {
336	48414x	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	110x	assert_number(lower)
395	109x	assert_number(upper)
396	108x	assert_flag(finite)
397	107x	assert_flag(unique)
398
399	106x	result <- check_numeric(
400	106x	x,
401	106x	lower = lower,
402	106x	upper = upper,
403	106x	finite = finite,
404	106x	any.missing = FALSE,
405	106x	len = 2,
406	106x	unique = unique,
407	106x	sorted = TRUE
408		)
409
410	106x	if (!isTRUE(result)) {
411	24x	result <- paste("x must be a valid numerical range.", result)
412		}
413	106x	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	318x	assert_number(len, lower = 1, null.ok = TRUE)
448	318x	assert_number(min.len, lower = 1, null.ok = TRUE)
449	318x	assert_number(max.len, lower = 1, null.ok = TRUE)
450
451	318x	result <- check_character(
452	318x	x,
453	318x	len = len,
454	318x	min.len = min.len,
455	318x	max.len = max.len,
456	318x	any.missing = FALSE,
457		# https://stackoverflow.com/questions/446285/validate-sprintf-format-from-input-field-with-regex
458	318x	pattern = "%(?:\\d+\\$)?[+-]?(?:[ 0]\|'.{1})?-?\\d*(?:\\.\\d+)?[bcdeEufFgGosxX]",
459		)
460
461	318x	if (!isTRUE(result)) {
462	!	result <- paste("x must be a valid format specifier.", result)
463		}
464	318x	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 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	46x	assert_number(seed, null.ok = TRUE)
20
21	46x	if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
22	1x	runif(1)
23		}
24
25	46x	if (is.null(seed)) {
26	4x	get(".Random.seed", envir = .GlobalEnv)
27		} else {
28	42x	seed <- as.integer(seed)
29	42x	r_seed <- get(".Random.seed", envir = .GlobalEnv)
30		# Make sure r_seed exists in parent frame.
31	42x	assign(".r_seed", r_seed, envir = parent.frame())
32	42x	set.seed(seed)
33		# Here we need the r_seed in the parent.frame!
34	42x	do.call(
35	42x	"on.exit",
36	42x	list(quote(assign(".Random.seed", .r_seed, envir = .GlobalEnv))), # nolint
37	42x	envir = parent.frame()
38		)
39	42x	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	46x	assert_flag(parallel)
69	45x	assert_integerish(n_cores, lower = 1)
70
71	44x	if (!parallel) {
72	44x	lapply(
73	44x	X = seq_len(nsim),
74	44x	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	205x	do.call(
145	205x	truth,
146		## First argument: the dose
147	205x	c(
148	205x	dose,
149		## Following arguments
150	205x	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	15x	dataList <- lapply(resultList, "[[", "data")
168
169		## the vector of the final dose recommendations
170	15x	recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))
171
172		## setup the list for the final fits
173	15x	fitList <- lapply(resultList, "[[", "fit")
174
175		## the reasons for stopping
176	15x	stopReasons <- lapply(resultList, "[[", "stop")
177
178		# individual stopping rule results as matrix, labels as column names
179	15x	stopResults <- lapply(resultList, "[[", "report_results")
180	15x	stop_matrix <- as.matrix(do.call(rbind, stopResults))
181
182		# Result list of additional statistical summary.
183	15x	additional_stats <- lapply(resultList, "[[", "additional_stats")
184
185	15x	list(
186	15x	dataList = dataList,
187	15x	recommendedDoses = recommendedDoses,
188	15x	fitList = fitList,
189	15x	stopReasons = stopReasons,
190	15x	stopResults = stopResults,
191	15x	additional_stats = additional_stats,
192	15x	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	962x	label <- attr(stopit_tree, "report_label")
205	962x	value <- stopit_tree[1]
206	962x	names(value) <- label
207	962x	value
208	962x	if (is.null(attr(stopit_tree, "individual"))) {
209	741x	value
210		} else {
211	221x	unlist(c(
212	221x	value,
213	221x	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 (`number`)\cr defines the true probability for a DLT at the dose.
225		#' @param prob_placebo (`number`)\cr defines the true probability for a DLT at a placebo condition.
226		#' @param prob_response (`number`)\cr defines the true probability for a response at the dose.
227		#' @param prob_response_placebo (`number`)\cr defines the true probability for a response at a placebo condition.
228		#' @param cohort_size (`number`)\cr the cohort size to use.
229		#' @param cohort_size_placebo (`number`)\cr the cohort size to use for placebo condition.
230		#' @param dose_grid (`numeric`)\cr the dose_grid as specified by the user.
231		#' @param first_separate (`flag`)\cr whether the first patient is enrolled separately.
232		#' @return updated data object
233		#' @keywords internal
234
235		h_determine_dlts <- function(
236		data,
237		dose,
238		prob,
239		prob_placebo = 0,
240		prob_response = 0,
241		prob_response_placebo = 0,
242		cohort_size,
243		cohort_size_placebo = 0,
244		dose_grid,
245		first_separate
246		) {
247	299x	assert_class(data, "Data")
248	299x	assert_number(dose)
249	299x	assert_number(prob, lower = 0, upper = 1)
250	299x	assert_number(prob_placebo, lower = 0, upper = 1, null.ok = TRUE)
251	299x	assert_number(prob_response, lower = 0, upper = 1)
252	299x	assert_number(prob_response_placebo, lower = 0, upper = 1, null.ok = TRUE)
253	299x	assert_number(cohort_size)
254	299x	assert_number(cohort_size_placebo, null.ok = TRUE)
255	299x	assert_flag(first_separate)
256
257	299x	if (first_separate && cohort_size > 1) {
258	34x	dlts <- rbinom(n = 1, size = 1, prob = prob)
259	34x	response <- rbinom(n = 1, size = 1, prob = prob_response)
260	34x	if ((data@placebo) && cohort_size_placebo > 0) {
261	5x	dlts_placebo <- rbinom(n = 1, size = 1, prob = prob_placebo)
262	5x	response_placebo <- rbinom(
263	5x	n = 1,
264	5x	size = 1,
265	5x	prob = prob_response_placebo
266		)
267		}
268	34x	if (dlts == 0) {
269	21x	dlts <- c(dlts, rbinom(n = cohort_size - 1L, size = 1, prob = prob))
270	21x	response <- c(
271	21x	response,
272	21x	rbinom(n = cohort_size - 1L, size = 1, prob = prob_response)
273		)
274	21x	if ((data@placebo) && cohort_size_placebo > 0) {
275	5x	dlts_placebo <- c(
276	5x	dlts_placebo,
277	5x	rbinom(
278	5x	n = cohort_size_placebo - 1L,
279	5x	size = 1,
280	5x	prob = prob_placebo
281		)
282		)
283	5x	response_placebo <- c(
284	5x	response_placebo,
285	5x	rbinom(
286	5x	n = cohort_size_placebo - 1L,
287	5x	size = 1,
288	5x	prob = prob_response_placebo
289		)
290		)
291		}
292		}
293		} else {
294	265x	dlts <- rbinom(n = cohort_size, size = 1, prob = prob)
295	265x	response <- rbinom(n = cohort_size, size = 1, prob = prob_response)
296	265x	if ((data@placebo) && cohort_size_placebo > 0) {
297	11x	dlts_placebo <- rbinom(
298	11x	n = cohort_size_placebo,
299	11x	size = 1,
300	11x	prob = prob_placebo
301		)
302	11x	response_placebo <- rbinom(
303	11x	n = cohort_size_placebo,
304	11x	size = 1,
305	11x	prob = prob_response_placebo
306		)
307		}
308		}
309
310	299x	if ((data@placebo) && cohort_size_placebo > 0) {
311	16x	data <- update(
312	16x	object = data,
313	16x	x = data@doseGrid[1],
314	16x	y = dlts_placebo,
315	16x	response = response_placebo,
316	16x	check = FALSE
317		)
318
319		## update the data with active dose
320	16x	data <- update(
321	16x	object = data,
322	16x	x = dose,
323	16x	y = dlts,
324	16x	response = response,
325	16x	new_cohort = FALSE
326		)
327		} else {
328		## update the data with this cohort
329	283x	data <- update(
330	283x	object = data,
331	283x	x = dose,
332	283x	y = dlts,
333	283x	response = response
334		)
335		}
336	299x	data
337		}
338
339		#' Helper Function to Update Backfill Queue
340		#'
341		#' This function manages the backfill cohort queue by determining which
342		#' previous cohorts are open or closed for backfill enrollment.
343		#'
344		#' @param backfill_cohorts (`list`)\cr current queue of backfill cohorts.
345		#' @param data (`Data`)\cr current trial data.
346		#' @param dose (`number`)\cr current dose being evaluated.
347		#' @param backfill (`Backfill`)\cr with opening rules and cohort size.
348		#'
349		#' @return Updated `backfill_cohorts` list.
350		#'
351		#' @keywords internal
352		h_update_backfill_queue <- function(backfill_cohorts, data, dose, backfill) {
353		# Loop over all previous cohorts and check which are open for backfill.
354	66x	for (cohort in seq_len(max(data@cohort) - 1)) {
355	150x	open_for_backfill <- openCohort(
356	150x	opening = backfill@opening,
357	150x	cohort = cohort,
358	150x	data = data,
359	150x	dose = dose
360		)
361
362		# Note: we index the cohorts in the queue by their cohort number
363		# coerced as a string.
364	150x	cohort_string <- as.character(cohort)
365	150x	is_in_queue <- !is.null(backfill_cohorts[[cohort_string]])
366
367	150x	if (is_in_queue) {
368		# Make sure to not reopen full backfill cohorts.
369	24x	is_full <- backfill_cohorts[[cohort_string]]$current_size ==
370	24x	backfill_cohorts[[cohort_string]]$max_size
371		# Mark this cohort accordingly in the backfill queue.
372	24x	backfill_cohorts[[cohort_string]]$open <- !is_full &&
373	24x	open_for_backfill
374	126x	} else if (open_for_backfill) {
375		# Add this new cohort to the backfill queue.
376	24x	backfill_dose <- h_get_dose_for_cohort(data, cohort)
377	24x	backfill_cohort_size <- size(
378	24x	object = backfill@cohort_size,
379	24x	dose = backfill_dose,
380	24x	cohort = cohort,
381	24x	data = data
382		)
383	24x	backfill_cohorts[[as.character(cohort)]] <- list(
384	24x	dose = backfill_dose,
385	24x	cohort = cohort,
386	24x	current_size = 0L,
387	24x	max_size = backfill_cohort_size,
388	24x	open = TRUE # Mark as open.
389		)
390		}
391		}
392
393	66x	backfill_cohorts
394		}
395
396		#' Helper Function to Enroll Backfill Patients
397		#'
398		#' This function executes backfill enrollment according to the priority rule,
399		#' updating the data object, backfill cohort queue, and patient counter.
400		#'
401		#' @param backfill_cohorts (`list`)\cr current queue of backfill cohorts.
402		#' @param data (`Data`)\cr current trial data.
403		#' @param backfill (`Backfill`)\cr with priority and recruitment rules.
404		#' @param cohort_size (`count`)\cr size of the active cohort.
405		#' @param backfill_patients (`count`)\cr number of enrolled backfill patients.
406		#' @param current_args (`data.frame`)\cr arguments for the truth function.
407		#' @param truth (`function`)\cr defining true DLT probability.
408		#' @param truthResponse (`function`)\cr defining true response probability.
409		#'
410		#' @return List with updated `data`, `backfill_cohorts`, and
411		#' `backfill_patients`.
412		#'
413		#' @keywords internal
414		h_enroll_backfill_patients <- function(
415		backfill_cohorts,
416		data,
417		backfill,
418		cohort_size,
419		backfill_patients,
420		current_args,
421		truth,
422		truthResponse
423		) {
424		# Number of backfill patients we can enroll in this cycle.
425	66x	max_recruits <- maxRecruits(
426	66x	backfill@recruitment,
427	66x	active_cohort_size = cohort_size
428		)
429	66x	backfill_left <- backfill@max_size - backfill_patients
430	66x	max_recruits <- min(max_recruits, backfill_left)
431
432		# Enroll backfill cohorts.
433		if (
434	66x	length(backfill_cohorts) > 0 &&
435	66x	max_recruits > 0
436		) {
437	32x	backfill_doses <- sapply(
438	32x	backfill_cohorts,
439		"[[",
440	32x	"dose"
441		)
442		# Order backfill cohorts according to priority rule.
443	32x	order_indices <- switch(
444	32x	backfill@priority,
445	32x	highest = order(-backfill_doses),
446	32x	lowest = order(backfill_doses),
447	32x	random = sample.int(
448	32x	n = length(backfill_cohorts),
449	32x	size = length(backfill_cohorts)
450		)
451		)
452	32x	for (i_bc in order_indices) {
453	44x	bc <- backfill_cohorts[[i_bc]]
454	44x	if (!bc$open) {
455	20x	next
456		}
457	24x	enroll_size <- min(bc$max_size - bc$current_size, max_recruits)
458	24x	if (enroll_size == 0) {
459	!	next
460		}
461	24x	bc_dlts <- rbinom(
462	24x	n = enroll_size,
463	24x	size = 1,
464	24x	prob = h_this_truth(bc$dose, current_args, truth)
465		)
466	24x	bc_response <- rbinom(
467	24x	n = enroll_size,
468	24x	size = 1,
469	24x	prob = truthResponse(bc$dose)
470		)
471
472	24x	data <- update(
473	24x	object = data,
474	24x	x = bc$dose,
475	24x	y = bc_dlts,
476	24x	cohort = bc$cohort,
477	24x	response = bc_response,
478	24x	backfill = TRUE
479		)
480
481		# Record number of patients in the backfill cohort and overall.
482	24x	backfill_cohorts[[i_bc]]$current_size <-
483	24x	backfill_cohorts[[i_bc]]$current_size + enroll_size
484	24x	max_recruits <- max_recruits - enroll_size
485	24x	backfill_patients <- backfill_patients + enroll_size
486
487		# Close this cohort if it's fully enrolled.
488		if (
489	24x	backfill_cohorts[[i_bc]]$current_size ==
490	24x	backfill_cohorts[[i_bc]]$max_size
491		) {
492	24x	backfill_cohorts[[i_bc]]$open <- FALSE
493		}
494
495		# Stop enrolling backfill in this cycle if we reached the limit.
496	24x	if (max_recruits == 0) {
497	18x	break
498		}
499		}
500		}
501
502	66x	list(
503	66x	data = data,
504	66x	backfill_cohorts = backfill_cohorts,
505	66x	backfill_patients = backfill_patients
506		)
507		}

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	25x	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	16x	} else if (has_placebo) {
23		# Placebo will be plotted at y = 0 level.
24	12x	df$dose[df$dose == pbo_dose] <- 0
25		}
26	25x	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	23x	df <- data.frame(
75	23x	patient = seq_along(data@x),
76	23x	ID = paste(" ", data@ID),
77	23x	cohort = data@cohort,
78	23x	dose = data@x,
79	23x	toxicity = ifelse(data@y == 1, "Yes", "No"),
80		...
81		)
82	23x	df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
83	23x	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		mark_backfill = FALSE,
132		...
133		) {
134	15x	assert_flag(blind)
135	15x	assert_flag(legend)
136	15x	assert_flag(mark_backfill)
137	15x	assert_character(tox_labels, any.missing = FALSE, unique = TRUE)
138	15x	assert_integer(tox_shapes, any.missing = FALSE, unique = TRUE)
139	15x	assert_true(length(tox_shapes) == length(tox_labels))
140	15x	assert_subset(x@y, as.integer(0:(length(tox_shapes) - 1)))
141	15x	if (x@nObs == 0L) {
142	!	return()
143		}
144	15x	df <- h_plot_data_df(x, blind, ...)
145
146		# Determine shape key per-point, using open shapes for backfill patients.
147	15x	if (mark_backfill) {
148	2x	if (!("backfilled" %in% names(df))) {
149		# Try to obtain backfilled information from the object if available.
150	2x	df$backfilled <- if (
151	2x	methods::is(x, "Data") && length(x@backfilled) == nrow(df)
152		) {
153	2x	x@backfilled
154		} else {
155	!	rep(FALSE, nrow(df))
156		}
157		}
158	2x	df$shape_key <- ifelse(
159	2x	df$backfilled,
160	2x	paste0(df$toxicity, "_bf"),
161	2x	df$toxicity
162		)
163		} else {
164	13x	df$shape_key <- df$toxicity
165		}
166
167		# Build shape scale values, adding open-shape variants for backfill when needed.
168	15x	shape_values <- tox_shapes
169	15x	if (mark_backfill) {
170	2x	convert_to_open <- function(s) {
171		# Map common filled shapes to their open counterparts.
172	2x	switch(
173	4x	as.character(s),
174	2x	"16" = 1L, # filled circle -> open circle
175	2x	"17" = 2L, # filled triangle -> open triangle
176	!	"15" = 0L, # filled square -> open square
177	!	"18" = 5L, # filled diamond -> open diamond
178	!	"19" = 1L, # large filled circle -> open circle
179		# If already open or unknown, keep as-is
180	!	as.integer(s)
181		)
182		}
183	2x	bf_shapes <- vapply(unname(tox_shapes), convert_to_open, integer(1))
184	2x	names(bf_shapes) <- paste0(names(tox_shapes), "_bf")
185	2x	shape_values <- c(shape_values, bf_shapes)
186		}
187
188	15x	p <- ggplot(df, aes(x = .data$patient, y = .data$dose)) +
189	15x	geom_point(
190	15x	aes(shape = .data$shape_key, colour = .data$toxicity),
191	15x	size = 3
192		) +
193	15x	scale_colour_manual(
194	15x	name = "Toxicity",
195	15x	values = tox_labels,
196	15x	breaks = names(tox_labels),
197	15x	limits = names(tox_labels),
198	15x	drop = FALSE,
199	15x	guide = guide_legend(
200	15x	reverse = TRUE,
201	15x	override.aes = list(
202	15x	shape = unname(rev(tox_shapes[names(tox_labels)]))
203		)
204		)
205		) +
206	15x	scale_shape_manual(
207	15x	values = shape_values,
208	15x	guide = "none"
209		) +
210	15x	scale_x_continuous(breaks = df$patient, minor_breaks = NULL) +
211	15x	scale_y_continuous(
212	15x	breaks = sort(unique(c(0, df$dose))),
213	15x	minor_breaks = NULL,
214	15x	limits = c(0, max(df$dose) * 1.1)
215		) +
216	15x	xlab("Patient") +
217	15x	ylab("Dose Level")
218
219	15x	p <- p + h_plot_data_cohort_lines(df$cohort, placebo = x@placebo)
220
221	15x	if (!blind) {
222	9x	p <- p +
223	9x	geom_text(
224	9x	aes(label = .data$ID, size = 2),
225	9x	data = df,
226	9x	hjust = 0,
227	9x	vjust = 0.5,
228	9x	angle = 90,
229	9x	colour = "black",
230	9x	show.legend = FALSE
231		)
232		}
233
234	15x	if (!legend) {
235	6x	p <- p + theme(legend.position = "none")
236		}
237
238	15x	p
239		}
240
241		#' Helper Function Containing Common Functionality
242		#'
243		#' Used by `dose_grid_range-Data` and `dose_grid_range-DataOrdinal`
244		#' @param object (`Data` or `DataOrdinal`)\cr the object for which the dose grid
245		#' range is required
246		#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
247		#'
248		h_obtain_dose_grid_range <- function(object, ignore_placebo) {
249	267x	assert_flag(ignore_placebo)
250
251	265x	dose_grid <- if (ignore_placebo && object@placebo && object@nGrid >= 1) {
252	96x	object@doseGrid[-1]
253		} else {
254	169x	object@doseGrid
255		}
256
257	265x	if (length(dose_grid) == 0L) {
258	10x	c(-Inf, Inf)
259		} else {
260	255x	range(dose_grid)
261		}
262		}
263
264		#' Convert a Ordinal Data to the Equivalent Binary Data for a Specific
265		#' Grade
266		#'
267		#' @description `r lifecycle::badge("experimental")`
268		#'
269		#' A simple helper function that takes a [`DataOrdinal`] object and an
270		#' integer grade and converts them to the equivalent `Data` object.
271		#'
272		#' @param data_ord (`DataOrdinal`)\cr the `DataOrdinal` object to covert
273		#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
274		#' is required.
275		#' @return A [`Data`] object.
276		#'
277		#' @export
278		h_convert_ordinal_data <- function(data_ord, grade) {
279		# Validate
280	33x	assert_integer(grade, len = 1, lower = 1)
281	33x	assert_class(data_ord, "DataOrdinal")
282		# Execute
283	33x	Data(
284	33x	ID = data_ord@ID,
285	33x	cohort = data_ord@cohort,
286	33x	x = data_ord@x,
287	33x	y = as.integer(data_ord@y >= grade),
288	33x	doseGrid = data_ord@doseGrid,
289	33x	nGrid = data_ord@nGrid,
290	33x	xLevel = data_ord@xLevel,
291	33x	placebo = data_ord@placebo
292		)
293		}

1		#' Set Default Values for kable Parameters
2		#'
3		#' Sets default values for `col.names` and `caption` if not already provided
4		#' by the user in the parameter list.
5		#'
6		#' @param param (`list`)\cr The list of `...` parameters passed to `knit_print`
7		#' @param col_names (`character`)\cr Default column names for the table
8		#' @param caption (`character`)\cr Default caption for the table
9		#' @return The updated parameter list with defaults applied
10		#' @keywords internal
11		h_kable_param_default <- function(param, col_names = NULL, caption = NULL) {
12	197x	assert_list(param)
13	196x	if (!is.null(col_names)) {
14	192x	assert_character(col_names, any.missing = FALSE)
15	191x	if (!("col.names" %in% names(param))) {
16	190x	param[["col.names"]] <- col_names
17		}
18		}
19	195x	if (!is.null(caption)) {
20	192x	assert_character(caption, len = 1, any.missing = FALSE)
21	190x	if (!("caption" %in% names(param))) {
22	189x	param[["caption"]] <- caption
23		}
24		}
25	193x	param
26		}
27
28		#' Check That Labels Are Valid and Useful
29		#'
30		#' A vector of labels is valid and useful if it is of length 2, of type character
31		#' and its values are distinct.
32		#'
33		#' If `x` is a scalar, a second element is added, whose value is the value of the
34		#' scalar with "s" appended. If `x` is `"toxicity"`, the plural is handled appropriately.
35		#'
36		#' @param x (`character`)\cr The vector to be checked
37		#' @keywords internal
38		#' @return a character vector of length 2 whose values are distinct
39		h_prepare_labels <- function(x) {
40	766x	assert_character(
41	766x	x,
42	766x	min.len = 1,
43	766x	max.len = 2,
44	766x	any.missing = FALSE,
45	766x	unique = TRUE
46		)
47
48	759x	if (length(x) == 1) {
49	462x	if (x == "toxicity") {
50	197x	x <- c("toxicity", "toxicities")
51		} else {
52	265x	x[2] <- paste0(x[1], "s")
53		}
54		}
55	759x	x
56		}
57
58		#' Append Units to a Numeric Dose
59		#'
60		#' @param units (`character`)\cr the units to be displayed
61		#' @keywords internal
62		#' @return if `units` is `NA`, then `NA`. Otherwise, `units`, ensuring that exactly
63		#' one space precedes the first non-whitespace character
64		h_prepare_units <- function(units = NA) {
65	292x	assert_character(units, len = 1)
66
67	292x	ifelse(
68	292x	is.na(units),
69		"",
70	292x	paste0(" ", stringr::str_trim(units, "left"))
71		)
72		}

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	78x	assert_flag(asis)
21
22	76x	param <- h_kable_param_default(
23	76x	list(...),
24	76x	col_names = c("Min", "Max", "Increment"),
25	76x	caption = "Defined by highest dose administered so far"
26		)
27	76x	x <- tidy(x)
28	76x	param[["x"]] <- x
29	76x	rv <- kableExtra::add_header_above(
30	76x	do.call(knitr::kable, param),
31	76x	c("Dose" = 2, " " = 1)
32		)
33	76x	rv <- paste0(rv, "\n\n")
34
35	76x	if (asis) {
36	9x	rv <- knitr::asis_output(rv)
37		}
38	76x	rv
39		}
40
41		#' Render an `IncrementsRelativeDLT` object
42		#'
43		#' @description `r lifecycle::badge("experimental")`
44		#' @inherit knit_print.CohortSizeConst return
45		#' @param ... passed to [knitr::kable()]
46		#' @inheritParams knit_print.CohortSizeConst
47		#' @section Usage Notes:
48		#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
49		#' of `caption` is `"Defined by number of DLTs reported so far"`. These values
50		#' can be overridden by passing `col.names` and `caption` in the function call.
51		#' @export
52		#' @method knit_print IncrementsRelativeDLT
53		#' @rdname knit_print
54		knit_print.IncrementsRelativeDLT <- function(x, ..., asis = TRUE) {
55	12x	assert_flag(asis)
56
57	10x	param <- h_kable_param_default(
58	10x	list(...),
59	10x	col_names = c("Min", "Max", "Increment"),
60	10x	caption = "Defined by number of DLTs reported so far"
61		)
62	10x	param[["x"]] <- tidy(x)
63	10x	rv <- kableExtra::add_header_above(
64	10x	do.call(knitr::kable, param),
65	10x	c("No DLTs" = 2, " " = 1)
66		)
67	10x	rv <- paste0(rv, "\n\n")
68
69	10x	if (asis) {
70	6x	rv <- knitr::asis_output(rv)
71		}
72	10x	rv
73		}
74
75		#' Render an `IncrementsDoseLevels` object
76		#'
77		#' @description `r lifecycle::badge("experimental")`
78		#' @inherit knit_print.CohortSizeConst return
79		#' @inheritParams knit_print.CohortSizeConst
80		#' @export
81		#' @rdname knit_print
82		#' @method knit_print IncrementsDoseLevels
83		knit_print.IncrementsDoseLevels <- function(x, ..., asis = TRUE) {
84	7x	assert_flag(asis)
85
86	5x	rv <- paste0(
87	5x	"The maximum increment between cohorts is ",
88	5x	x@levels,
89	5x	ifelse(x@levels == 1, " level", " levels"),
90	5x	" relative to the ",
91	5x	ifelse(
92	5x	x@basis_level == "last",
93	5x	"dose used in the previous cohort.",
94	5x	"highest dose used so far."
95		),
96	5x	"\n\n"
97		)
98
99	5x	if (asis) {
100	3x	rv <- knitr::asis_output(rv)
101		}
102	5x	rv
103		}
104
105		#' Render an `IncrementsHSRBeta` object
106		#'
107		#' @description `r lifecycle::badge("experimental")`
108		#' @inherit knit_print.CohortSizeConst return
109		#' @inheritParams knit_print.CohortSizeConst
110		#' @export
111		#' @method knit_print IncrementsHSRBeta
112		#' @rdname knit_print
113		knit_print.IncrementsHSRBeta <- function(x, ..., asis = TRUE) {
114	7x	assert_flag(asis)
115
116	5x	rv <- paste0(
117	5x	"The maximum increment is defined by a hard safety rule, independent of the CRM model, ",
118	5x	" and based on a beta(",
119	5x	x@a,
120		", ",
121	5x	x@b,
122		") ",
123	5x	"prior with a target toxicity rate of ",
124	5x	x@target,
125	5x	" and a probability threshold of ",
126	5x	x@prob,
127	5x	".\n\n"
128		)
129
130	5x	if (asis) {
131	3x	rv <- knitr::asis_output(rv)
132		}
133	5x	rv
134		}
135
136		#' Render an `IncrementsMin` object
137		#'
138		#' @description `r lifecycle::badge("experimental")`
139		#' @inherit knit_print.CohortSizeConst return
140		#' @param ... passed through to the `knit_print` methods of the constituent
141		#' rules
142		#' @inheritParams knit_print.CohortSizeConst
143		#' @export
144		#' @method knit_print IncrementsMin
145		#' @rdname knit_print
146		knit_print.IncrementsMin <- function(x, ..., asis = TRUE) {
147	7x	assert_flag(asis)
148
149	5x	rv <- paste0(
150	5x	"The minimum of the increments defined in the following rules:",
151	5x	paste0(
152	5x	lapply(
153	5x	x@increments_list,
154	5x	function(x, ...) {
155	10x	knit_print(x, asis = asis, ...)
156		}
157		),
158	5x	collapse = "\n"
159		),
160	5x	"\n\n",
161	5x	paste = "\n"
162		)
163
164	5x	if (asis) {
165	3x	rv <- knitr::asis_output(rv)
166		}
167	5x	rv
168		}
169
170		#' Render an `IncrementsOrdinal` object
171		#' @inherit knit_print.CohortSizeConst return
172		#' @param ... passed through to the `knit_print` method of the standard rule
173		#' @inheritParams knit_print.CohortSizeConst
174		#' @export
175		#' @method knit_print IncrementsOrdinal
176		#' @rdname knit_print
177		knit_print.IncrementsOrdinal <- function(x, ..., asis = TRUE) {
178	11x	assert_flag(asis)
179
180	9x	rv <- paste0(
181	9x	"Based on a toxicity grade of ",
182	9x	x@grade,
183		": ",
184	9x	paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n"),
185	9x	"\n\n",
186	9x	paste = "\n"
187		)
188
189	9x	if (asis) {
190	3x	rv <- knitr::asis_output(rv)
191		}
192	9x	rv
193		}
194
195		#' Render an `IncrementsRelativeParts` object
196		#'
197		#' @inherit knit_print.CohortSizeConst return
198		#' @param tox_label (`character`)\cr The word used to describe toxicities. See
199		#' Usage Notes below.
200		#' @inheritParams knit_print.CohortSizeConst
201		#' @section Usage Notes:
202		#' `label` defines how toxicities are described.
203		#'
204		#' It should be a character vector of length 1 or 2. If of length 2, the first
205		#' element describes a single toxicity and the second describes all other
206		#' toxicity counts. If of length 1, the character `s` is appended to the value
207		#' describing a single toxicity.
208		#'
209		#' @export
210		#' @method knit_print IncrementsRelativeParts
211		#' @rdname knit_print
212		knit_print.IncrementsRelativeParts <- function(
213		x,
214		...,
215		asis = TRUE,
216		tox_label = c("toxicity", "toxicities")
217		) {
218	13x	assert_flag(asis)
219
220	11x	tox_label <- h_prepare_labels(tox_label)
221	11x	rv <- paste0(
222	11x	"The maximum increment in Part 1 is defined by the `part1Ladder` slot of ",
223	11x	"the associated `DataParts` object.\n\n",
224	11x	"If no ",
225	11x	tox_label[2],
226	11x	" are reported in Part 1, the starting dose for Part 2 ",
227	11x	"will be ",
228	11x	ifelse(
229	11x	x@clean_start == 0,
230	11x	"the highest dose used in Part 1.\n\n",
231	11x	paste0(
232	11x	x@clean_start,
233	11x	ifelse(abs(x@clean_start) == 1, " dose ", " doses "),
234	11x	ifelse(x@clean_start < 0, "below ", "above "),
235	11x	"the highest dose used in Part 1.\n\n"
236		)
237		),
238	11x	"If one or more ",
239	11x	tox_label[2],
240	11x	" are reported in Part 1, the starting dose for Part 2 ",
241	11x	"will be ",
242	11x	ifelse(
243	11x	x@dlt_start == 0,
244	11x	"the highest dose used in Part 1.\n\n",
245	11x	paste0(
246	11x	abs(x@dlt_start),
247	11x	ifelse(abs(x@dlt_start) == 1, " dose ", " doses "),
248	11x	ifelse(x@dlt_start < 0, "below ", "above "),
249	11x	"the highest dose used in Part 1.\n\n"
250		)
251		),
252	11x	"Once Part 2 has started, the maximum increment in dose levels will be based ",
253	11x	"on the number of ",
254	11x	tox_label[2],
255	11x	" reported so far, as described in the ",
256	11x	"following table:"
257		)
258
259	11x	param <- h_kable_param_default(
260	11x	list(...),
261	11x	col_names = c("Lower", "Upper", "Increment"),
262	11x	caption = paste0(
263	11x	"Defined by the number of ",
264	11x	tox_label[2],
265	11x	" reported so far"
266		)
267		)
268	11x	header <- c(2, 1)
269	11x	headerLabel <- tox_label[2]
270	11x	substr(headerLabel, 1, 1) <- toupper(substr(headerLabel, 1, 1))
271	11x	names(header) <- c(headerLabel, " ")
272	11x	param[["x"]] <- tibble(
273	11x	intervals = x@intervals
274		) \|>
275	11x	h_range_to_minmax(intervals) \|>
276	11x	tibble::add_column(increments = c(0, x@increments))
277	11x	d_tab <- kableExtra::add_header_above(
278	11x	do.call(knitr::kable, param),
279	11x	header
280		)
281	11x	rv <- paste(rv, d_tab, "\n\n")
282	11x	if (asis) {
283	9x	rv <- knitr::asis_output(rv)
284		}
285	11x	rv
286		}
287
288		#' Render an `IncrementsRelativeDLTCurrent` object
289		#'
290		#' @description `r lifecycle::badge("experimental")`
291		#' @inherit knit_print.CohortSizeConst return
292		#' @param tox_label (`character`)\cr The word used to describe toxicities. See
293		#' Usage Notes below.
294		#' @param ... passed to [knitr::kable()]
295		#' @inheritParams knit_print.CohortSizeConst
296		#' @section Usage Notes:
297		#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
298		#' of `caption` is `"Defined by number of DLTs in the current cohort"`. These values
299		#' can be overridden by passing `col.names` and `caption` in the function call.
300		#'
301		#' `tox_label` defines how toxicities are described.
302		#'
303		#' It should be a character vector of length 1 or 2. If of length 2, the first
304		#' element describes a single toxicity and the second describes all other
305		#' toxicity counts. If of length 1, the character `s` is appended to the value
306		#' describing a single toxicity.
307		#'
308		#' @export
309		#' @method knit_print IncrementsRelativeDLTCurrent
310		#' @rdname knit_print
311		knit_print.IncrementsRelativeDLTCurrent <- function(
312		x,
313		...,
314		asis = TRUE,
315		tox_label = c("DLT", "DLTs")
316		) {
317	7x	assert_flag(asis)
318	5x	tox_label <- h_prepare_labels(tox_label)
319
320	5x	param <- h_kable_param_default(
321	5x	list(...),
322	5x	col_names = c("Min", "Max", "Increment"),
323	5x	caption = paste0(
324	5x	"Defined by number of ",
325	5x	tox_label[2],
326	5x	" reported in the current cohort"
327		)
328		)
329	5x	param[["x"]] <- tidy(x)
330	5x	header_text <- c(2, 1)
331	5x	names(header_text) <- c(paste0("No ", tox_label[2]), " ")
332	5x	rv <- kableExtra::add_header_above(
333	5x	do.call(knitr::kable, param),
334	5x	header_text
335		)
336	5x	rv <- paste0(rv, "\n\n")
337
338	5x	if (asis) {
339	3x	rv <- knitr::asis_output(rv)
340		}
341	5x	rv
342		}

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	38x	assert_number(xaxisround, lower = 0)
14	36x	assert_character(description, len = 1, any.missing = FALSE)
15	34x	assert_numeric(x)
16
17	33x	tabx <- table(x) / length(x)
18	33x	dat <- data.frame(x = as.numeric(names(tabx)), perc = as.numeric(tabx) * 100)
19	33x	ggplot() +
20	33x	geom_bar(
21	33x	aes(x = x, y = perc),
22	33x	data = dat,
23	33x	stat = "identity",
24	33x	position = "identity",
25	33x	width = ifelse(nrow(dat) > 1, min(diff(dat$x)) / 2, 1)
26		) +
27	33x	xlab(description) +
28	33x	ylab("Percent") +
29	33x	scale_x_continuous(
30	33x	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	52x	stop_pct <- colMeans(stop_report) * 100
46	52x	stop_pct_to_print <- stop_pct[!is.na(names(stop_pct))]
47	52x	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	list(param_names, averages)
71		}

1		#' @include Backfill-class.R
2		#' @include helpers.R
3		NULL
4
5		# openCohort ----
6
7		## generic ----
8
9		#' Open / recruit backfill patients into a cohort?
10		#'
11		#' @description `r lifecycle::badge("experimental")`
12		#'
13		#' @param opening (`Opening`)\cr opening rule to be applied.
14		#' @param cohort (`int`)\cr backfill cohort index.
15		#' @param data (`Data`)\cr current trial data.
16		#' @param dose (`numeric`)\cr the recommended next best dose.
17		#' @param ... further arguments (not used).
18		#'
19		#' @return `TRUE` if this backfill cohort can be opened / recruited into,
20		#' `FALSE` otherwise.
21		setGeneric(
22		name = "openCohort",
23		def = function(opening, cohort, data, dose, ...) {
24		# For any opening rule, if the dose of the cohort to be opened
25		# is higher than or equal to the recommended dose, do not open it.
26	418x	cohort_dose <- h_get_dose_for_cohort(data, cohort)
27	418x	if (is.na(cohort_dose) \|\| cohort_dose >= dose) {
28	18x	return(FALSE)
29		}
30	400x	standardGeneric("openCohort")
31		},
32		valueClass = "logical"
33		)
34
35		## OpeningMinDose ----
36
37		#' @describeIn openCohort method for `OpeningMinDose` class.
38		#'
39		#' @aliases openCohort-OpeningMinDose
40		#'
41		#' @export
42		#' @example examples/Backfill-method-openCohort-OpeningMinDose.R
43		setMethod(
44		f = "openCohort",
45		signature = c(opening = "OpeningMinDose"),
46		definition = function(opening, cohort, data, dose, ...) {
47	144x	cohort_dose <- h_get_dose_for_cohort(data, cohort)
48	144x	(!is.na(cohort_dose) &&
49	144x	cohort_dose >= opening@min_dose)
50		}
51		)
52
53		## OpeningMinCohorts ----
54
55		#' @describeIn openCohort method for `OpeningMinCohorts` class.
56		#'
57		#' @aliases openCohort-OpeningMinCohorts
58		#'
59		#' @export
60		#' @example examples/Backfill-method-openCohort-OpeningMinCohorts.R
61		setMethod(
62		f = "openCohort",
63		signature = c(opening = "OpeningMinCohorts"),
64		definition = function(opening, cohort, data, dose, ...) {
65	125x	n_cohorts <- max(data@cohort)
66	125x	n_cohorts >= opening@min_cohorts
67		}
68		)
69
70		## OpeningNone ----
71
72		#' @describeIn openCohort method for `OpeningNone` class, which never opens a cohort, i.e.
73		#' the trial design will not use backfilling.
74		#'
75		#' @aliases openCohort-OpeningNone
76		#'
77		#' @export
78		#' @example examples/Backfill-method-openCohort-OpeningNone.R
79		setMethod(
80		f = "openCohort",
81		signature = c(opening = "OpeningNone"),
82		definition = function(opening, cohort, data, dose, ...) {
83	3x	FALSE
84		}
85		)
86
87		## OpeningMinResponses ----
88
89		#' @describeIn openCohort method for `OpeningMinResponses` class.
90		#'
91		#' @aliases openCohort-OpeningMinResponses
92		#'
93		#' @export
94		#' @example examples/Backfill-method-openCohort-OpeningMinResponses.R
95		setMethod(
96		f = "openCohort",
97		signature = c(opening = "OpeningMinResponses"),
98		definition = function(opening, cohort, data, dose, ...) {
99	6x	cohort_dose <- h_get_dose_for_cohort(data, cohort)
100
101		# Count responses based on include_lower_doses flag
102	6x	if (opening@include_lower_doses) {
103		# Count responses at cohort_dose and all lower doses
104	3x	response_count <- sum(data@response[data@x <= cohort_dose], na.rm = TRUE)
105		} else {
106		# Count responses only at cohort_dose
107	3x	response_count <- sum(data@response[data@x == cohort_dose], na.rm = TRUE)
108		}
109
110	6x	response_count >= opening@min_responses
111		}
112		)
113
114		## OpeningList ----
115
116		#' @describeIn openCohort method for `OpeningList` class.
117		#'
118		#' @aliases openCohort-OpeningList
119		#'
120		#' @param summary_fun (`function`)\cr to apply to the list of
121		#' results (e.g., `all` or `any`).
122		#' Only used for `OpeningList` and its subclasses.
123		#'
124		setMethod(
125		f = "openCohort",
126		signature = c(opening = "OpeningList"),
127		definition = function(opening, cohort, data, dose, summary_fun, ...) {
128	122x	list_results <- vapply(
129	122x	opening@open_list,
130	122x	FUN = function(op) openCohort(op, cohort, data, dose, ...),
131	122x	FUN.VALUE = logical(1)
132		)
133	122x	summary_fun(list_results)
134		}
135		)
136
137		## OpeningAll ----
138
139		#' @describeIn openCohort method for `OpeningAll` class.
140		#' Returns `TRUE` if ALL opening criteria are satisfied.
141		#'
142		#' @aliases openCohort-OpeningAll
143		#'
144		#' @export
145		#' @example examples/Backfill-method-openCohort-OpeningAll.R
146		setMethod(
147		f = "openCohort",
148		signature = c(opening = "OpeningAll"),
149		definition = function(opening, cohort, data, dose, ...) {
150	118x	callNextMethod(opening, cohort, data, dose, summary_fun = all, ...)
151		}
152		)
153
154		## OpeningAny ----
155
156		#' @describeIn openCohort method for `OpeningAny` class.
157		#' Returns `TRUE` if ANY opening criteria are satisfied.
158		#'
159		#' @aliases openCohort-OpeningAny
160		#'
161		#' @export
162		#' @example examples/Backfill-method-openCohort-OpeningAny.R
163		setMethod(
164		f = "openCohort",
165		signature = c(opening = "OpeningAny"),
166		definition = function(opening, cohort, data, dose, ...) {
167	4x	callNextMethod(opening, cohort, data, dose, summary_fun = any, ...)
168		}
169		)
170
171		## & operator ----
172
173		#' Logical AND Operator for Opening Objects
174		#'
175		#' @description `r lifecycle::badge("experimental")`
176		#'
177		#' Combines two [`Opening`] objects with AND logic using the `&` operator.
178		#' This creates an [`OpeningAll`] object.
179		#'
180		#' @param e1 (`Opening`)
181		#' the first opening object.
182		#' @param e2 (`Opening`)
183		#' the second opening object.
184		#'
185		#' @return An [`OpeningAll`] object combining `e1` and `e2`.
186		#'
187		#' @seealso [`OpeningAll`] for more details.
188		#'
189		#' @export
190		#' @name and,Opening,Opening-method
191		#' @aliases &,Opening,Opening-method
192		setMethod(
193		f = "&",
194		signature = c(e1 = "Opening", e2 = "Opening"),
195		definition = function(e1, e2) {
196	3x	.OpeningAll(open_list = list(e1, e2))
197		}
198		)
199
200		## \| operator ----
201
202		#' Logical OR Operator for Opening Objects
203		#'
204		#' @description `r lifecycle::badge("experimental")`
205		#'
206		#' Combines two [`Opening`] objects with OR logic using the `\|` operator.
207		#' This creates an [`OpeningAny`] object.
208		#'
209		#' @param e1 (`Opening`)
210		#' the first opening object.
211		#' @param e2 (`Opening`)
212		#' the second opening object.
213		#'
214		#' @return An [`OpeningAny`] object combining `e1` and `e2`.
215		#'
216		#' @seealso [`OpeningAny`] for more details.
217		#'
218		#' @export
219		#' @name or,Opening,Opening-method
220		#' @aliases \|,Opening,Opening-method
221		setMethod(
222		f = "\|",
223		signature = c(e1 = "Opening", e2 = "Opening"),
224		definition = function(e1, e2) {
225	2x	.OpeningAny(open_list = list(e1, e2))
226		}
227		)
228
229		# maxRecruits ----
230
231		## generic ----
232
233		#' Calculate Maximum Number of Backfill Patients
234		#'
235		#' @description `r lifecycle::badge("experimental")`
236		#'
237		#' Calculates the maximum number of backfill patients that can be recruited
238		#' based on the recruitment rule and the active cohort size.
239		#'
240		#' @param object (`Recruitment`)\cr the recruitment rule.
241		#' @param active_cohort_size (`integer`)\cr the current size of the active
242		#' dose escalation cohort.
243		#' @param ... further arguments (not used).
244		#'
245		#' @return The maximum number of backfill patients as an `integer`.
246		#'
247		#' @seealso [`Recruitment`], [`RecruitmentUnlimited`], [`RecruitmentRatio`].
248		#'
249		setGeneric(
250		name = "maxRecruits",
251		def = function(object, active_cohort_size, ...) {
252	75x	standardGeneric("maxRecruits")
253		},
254		valueClass = "integer"
255		)
256
257		## RecruitmentUnlimited ----
258
259		#' @describeIn maxRecruits method for `RecruitmentUnlimited` class.
260		#' Returns a very large number (practically unlimited).
261		#'
262		#' @aliases maxRecruits-RecruitmentUnlimited
263		#'
264		#' @export
265		#' @example examples/Backfill-method-maxRecruits-RecruitmentUnlimited.R
266		setMethod(
267		f = "maxRecruits",
268		signature = c(object = "RecruitmentUnlimited"),
269		definition = function(object, active_cohort_size, ...) {
270	13x	1e6L # Practically unlimited.
271		}
272		)
273
274		## RecruitmentRatio ----
275
276		#' @describeIn maxRecruits method for `RecruitmentRatio` class.
277		#' Returns `ceiling(ratio * active_cohort_size)`.
278		#'
279		#' @aliases maxRecruits-RecruitmentRatio
280		#'
281		#' @export
282		#' @example examples/Backfill-method-maxRecruits-RecruitmentRatio.R
283		setMethod(
284		f = "maxRecruits",
285		signature = c(object = "RecruitmentRatio"),
286		definition = function(object, active_cohort_size, ...) {
287	62x	ratio <- object@ratio
288	62x	max_recruits <- as.integer(ceiling(ratio * active_cohort_size))
289	62x	max_recruits
290		}
291		)

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	74469x	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	72964x	if (!h_covr_active()) {
48	2x	return(expr)
49		}
50
51	72962x	if (is.function(expr)) {
52	9x	body(expr) <- h_covr_detrace(body(expr))
53	9x	return(expr)
54		}
55
56	72953x	detrace <- function(x) {
57		# returns "missing" expression to avoid errors with calls
58	72953x	if (identical(x, bquote())) {
59	345x	return(x)
60		}
61
62	72608x	x <- h_covr_detrace_call(x)
63	72608x	if (is.call(x)) {
64	35806x	x[-1] <- lapply(x[-1], h_covr_detrace)
65		}
66	72608x	x
67		}
68
69	72953x	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	72613x	is.call(expr) &&
77	72613x	expr[[1]] == "if" &&
78	72613x	expr[[2]] == quote(TRUE) &&
79	72613x	expr[[3]][[1]] == "{" &&
80	72613x	length(expr[[3]]) >= 3 &&
81	72613x	is.call(expr[[3]][[2]]) &&
82	72613x	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	5182x	if (h_is_covr_trace(expr)) expr[[3]][[3]] else expr
89		}

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		#' @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		# Design ----
2
3		#' Internal Helper Functions for Validation of [`RuleDesign`] Objects
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' These functions are only used internally to validate the format of an input
8		#' [`RuleDesign`] or inherited classes and therefore not exported.
9		#'
10		#' @name v_design
11		#' @param object (`RuleDesign`)\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_design validates that the [`RuleDesign`] object
17		#' contains valid `startingDose`.
18		v_rule_design <- function(object) {
19	10x	v <- Validate()
20	10x	v$check(
21	10x	test_number(object@startingDose, finite = TRUE),
22	10x	"startingDose must be a number"
23		)
24	10x	v$check(
25	10x	test_subset(
26	10x	object@startingDose,
27	10x	choices = object@data@doseGrid,
28	10x	empty.ok = FALSE
29		),
30	10x	"startingDose must be included in data@doseGrid"
31		)
32	10x	v$result()
33		}
34
35		#' Internal Helper Functions for Validation of [`RuleDesignOrdinal`] Objects
36		#'
37		#' @description `r lifecycle::badge("experimental")`
38		#'
39		#' These functions are only used internally to validate the format of an input
40		#' [`RuleDesignOrdinal`] or inherited classes and therefore not exported.
41		#'
42		#' @name v_design
43		#' @param object (`RuleDesignOrdinal`)\cr object to validate.
44		#' @return A `character` vector with the validation failure messages,
45		#' or `TRUE` in case validation passes.
46		NULL
47
48		#' @describeIn v_design validates that the [`RuleDesignOrdinal`] object
49		#' contains valid `starting_dose`.
50		v_rule_design_ordinal <- function(object) {
51	!	v <- Validate()
52	!	v$check(
53	!	test_number(object@starting_dose, finite = TRUE),
54	!	"starting_dose must be a number"
55		)
56	!	v$check(
57	!	test_subset(
58	!	object@starting_dose,
59	!	choices = object@data@doseGrid,
60	!	empty.ok = FALSE
61		),
62	!	"starting_dose must be included in data@doseGrid"
63		)
64	!	v$result()
65		}
66
67
68		#' @describeIn v_design validates that the [`DesignGrouped`] object
69		#' contains valid flags.
70		v_design_grouped <- function(object) {
71	2x	v <- Validate()
72	2x	v$check(
73	2x	test_flag(object@first_cohort_mono_only),
74	2x	"first_cohort_mono_only must be a flag"
75		)
76	2x	v$check(
77	2x	test_flag(object@same_dose_for_all),
78	2x	"same_dose_for_all must be a flag"
79		)
80	2x	v$check(
81	2x	test_flag(object@same_dose_for_all),
82	2x	"same_dose_for_start must be a flag"
83		)
84	2x	v$result()
85		}

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	3409x	assert_count(burnin, positive = TRUE)
84	3409x	assert_count(step, positive = TRUE)
85	3409x	assert_count(samples, positive = TRUE)
86	3409x	assert_string(rng_kind, na.ok = TRUE)
87	3409x	assert_count(rng_seed, na.ok = TRUE)
88
89	3409x	if (!is.na(rng_kind)) {
90	370x	rng_kind <- paste0("base::", rng_kind)
91		} else {
92	3039x	rng_kind <- NA_character_
93		}
94	3409x	if (!is.na(rng_seed)) {
95	369x	rng_seed <- as.integer(rng_seed)
96		} else {
97	3040x	rng_seed <- NA_integer_
98		}
99
100	3409x	.McmcOptions(
101	3409x	iterations = as.integer(burnin + (step * samples)),
102	3409x	burnin = as.integer(burnin),
103	3409x	step = as.integer(step),
104	3409x	rng_kind = rng_kind,
105	3409x	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	18x	McmcOptions(
116	18x	burnin = 250,
117	18x	samples = 1000
118		)
119		}

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		#' @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	93456x	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	48259x	iterations_relative <- object@iterations - object@burnin
42	48259x	if (iterations_relative <= 0) {
43	!	return(0L)
44		}
45	48259x	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	21914x	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	21914x	iteration_relative <- iteration - object@burnin
86	21914x	iteration_relative > 0 && ((iteration_relative %% object@step) == 0)
87		}
88		)

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	1023x	logger <- futile.logger::flog.logger(name = "crmPack")
48	1023x	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	1574x	assert_string(msg)
61	1574x	assert_flag(capture)
62
63	1574x	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	853x	assert_matrix(
52	853x	cov,
53	853x	mode = "numeric",
54	853x	any.missing = FALSE,
55	853x	nrows = length(mean),
56	853x	ncols = length(mean)
57		)
58		# To ensure that `cov` is invertible:
59	853x	assert_true(h_is_positive_definite(cov, length(mean)))
60
61	853x	.ModelParamsNormal(
62	853x	mean = mean,
63	853x	cov = cov,
64	853x	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	7x	ModelParamsNormal(
75	7x	mean = c(1, 0),
76	7x	cov = matrix(c(1, 0, 0, 1), nrow = 2)
77		)
78		}

1		# Get the cohort index and dose of the previously added cohort.
2		h_previous_cohort <- function(data) {
3	!	last_cohort_index <- length(data@cohort)
4	!	last_cohort <- data@cohort[[last_cohort_index]]
5	!	previous_cohort <- last_cohort - 1L
6	!	previous_dose <- if (previous_cohort > 0) {
7	!	data@x[data@cohort == previous_cohort][1]
8		} else {
9	!	NA_real_
10		}
11	!	list(
12	!	cohort = previous_cohort,
13	!	dose = previous_dose
14		)
15		}
16
17		# Get the dose assigned to a given cohort.
18		h_get_dose_for_cohort <- function(data, cohort) {
19	592x	if (cohort > 0 && cohort <= length(data@cohort)) {
20	591x	data@x[data@cohort == cohort][1]
21		} else {
22		NA_real_
23		}
24		}

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	1092x	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	525x	rv <- h_tidy_all_slots(x) %>% h_tidy_class(x)
46	525x	if (length(rv) == 1) {
47	114x	rv[[names(rv)[1]]] %>% h_tidy_class(x)
48		} else {
49	411x	rv
50		}
51		}
52		)