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


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		}