jmpost coverage - 87.08%

Files
Source

#' @include SurvivalModel.R
NULL


#' `SurvivalGamma`
#'
#' This class extends the general [`SurvivalModel`] class for using the
#' Gamma survival model.
#'
#' @exportClass SurvivalGamma
.SurvivalGamma <- setClass(
    Class = "SurvivalGamma",
    contains = "SurvivalModel"
)

# SurvivalGamma-constructors ----

#' @rdname SurvivalGamma-class
#'
#' @typed k: Prior
#'   for the shape `k`.
#' @typed theta: Prior
#'   for the scale `theta`.
#' @typed beta: Prior
#'   for covariates coefficients `beta`.
#'
#' @export
SurvivalGamma <- function(
    k = prior_gamma(2, 0.5),
    theta = prior_gamma(2, 0.5),
    beta = prior_normal(0, 2)
) {
    k <- set_limits(k, lower = 0)
    theta <- set_limits(theta, lower = 0)

    .SurvivalGamma(
        SurvivalModel(
            name = "Gamma",
            stan = StanModule(x = "sm-gamma/model.stan"),
            parameters = ParameterList(
                Parameter(name = "sm_gamma_k", prior = k, size = 1),
                Parameter(name = "sm_gamma_theta", prior = theta, size = 1),
                Parameter(
                    name = "beta_os_cov",
                    prior = beta,
                    size = "p_os_cov_design"
                )
            )
        )
    )
}

#' Re-used documentation for Brier Score components
#'
#' @typed t: numeric
#'   timepoints to calculate the desired quantity at.
#' @typed times: numeric
#'   observed times.
#' @typed events: numeric
#'   event indicator for `times`. Either 1 for an event or 0 for censor.
#' @typed event_offset: logical
#'   If `TRUE` then \eqn{G(T_i)} is evaluated at \eqn{G(T_i-)}.
#'   Setting this as `TRUE` mirrors the implementation of the `{pec}` package.
#' @typed maintain_cen_order: logical
#'   If `TRUE` then, in the case of ties,
#'   censor times are always considered
#'   to have occurred after the event times when calculating the "reverse Kaplan-Meier" for the
#'   IPCW estimates. Setting this to `TRUE` mirrors the implementation of the `{prodlim}`
#'   package.
#' @param ... not used.
#'
#' @name Brier-Score-Shared
#' @keywords internal
NULL


#' Reverse Kaplan-Meier
#'
#' @inheritParams Brier-Score-Shared
#' @description
#' Calculates the survival estimates of the censoring distribution
#' using the Kaplan-Meier estimate.
#' This is primarily used in the calculation of the IPCW estimates.
#'
#' @details
#' With regards to ties between censor and event times; the standard
#' approach is to regard events as occurring before censors. However,
#' when modelling the censoring distribution we are regarding the
#' censors as "events" so which should come first in the case of ties?
#'
#' The `reverse_km_event_first()` function maintains the rule
#' that events always come first even if we are regarding the censors
#' as "events". This matches the implementation of
#' `prodlim::prodlim(..., reverse = TRUE)`.
#'
#' The `reverse_km_cen_first()` function provides the alternative
#' implementation assuming that in the case of ties the censor "events"
#' come before the event "censors". This is essentially a thin wrapper
#' around `survival::survfit(Surv(time, 1 - event), ...)`
#'
#' @name reverse_km
#' @keywords internal
reverse_km_event_first <- function(t, times, events) {
    assert_numeric(t, any.missing = FALSE, finite = TRUE)
    assert_numeric(times, any.missing = FALSE, finite = TRUE)
    assert_numeric(events, any.missing = FALSE, finite = TRUE)
    assert_that(
        length(times) == length(events),
        all(events == 1 | events == 0)
    )
    events_cen <- 1 - events
    ord <- order(times, events_cen)
    times <- times[ord]
    events <- events[ord]
    events_cen <- events_cen[ord]
    cs_events <- cumsum(events)
    cs_censor <- cumsum(events_cen)

    g_times <- unique(times)
    g_n_events_cen <- tapply(events_cen, times, sum)
    g_cs_events_cen <- tapply(cs_censor, times, max)
    g_cs_events <- tapply(cs_events, times, max)
    g_is_cen <- tapply(events_cen, times, max)

    nrisk <- length(times) - g_cs_events - g_cs_events_cen + g_n_events_cen
    surv_interval <- 1 - g_n_events_cen / nrisk
    surv_interval <- ifelse(nrisk == 0, 1, surv_interval)
    surv <- cumprod(surv_interval)

    ct <- g_times[which(g_is_cen == 1)]
    sv <- surv[which(g_is_cen == 1)]

    names(surv) <- NULL
    names(ct) <- NULL
    names(sv) <- NULL
    list(
        t = t,
        surv = c(1, sv)[findInterval(t, ct) + 1]
    )
}


#' @rdname reverse_km
reverse_km_cen_first <- function(t, times, events) {
    assert_numeric(t, any.missing = FALSE, finite = TRUE)
    assert_numeric(times, any.missing = FALSE, finite = TRUE)
    assert_numeric(events, any.missing = FALSE, finite = TRUE)
    assert_that(
        length(times) == length(events),
        all(events == 1 | events == 0)
    )
    dat <- data.frame(
        times = times,
        events = events,
        cen_events = 1 - events
    )
    mod <- survival::survfit(
        survival::Surv(times, cen_events) ~ 1,
        data = dat
    )
    preds <- summary(mod, times = t[order(t)], extend = TRUE)$surv

    assert_that(
        length(preds) == length(t)
    )
    list(
        t = t,
        surv = preds[match_order(t)]
    )
}

#' Match Order
#'
#' @typed x: numeric
#'   a vector for which we want to generate an index so other
#'   vectors can be put into the same sort order
#'
#'   Assuming we have a vector that is sorted then this function
#'   will return the index vector to convert that sorted vector
#'   into the same sort order as the input vector `x`.
#'   For example let `x = 8, 7, 9 , 7`. If sorted we would get
#'   `x_sort = 7, 7, 8, 9`. So in order to convert `x_sort`
#'   back into `x` we'd need an index vector of `3, 1, 4, 2`.
#'   This function is used to determine that corresponding
#'   index vector for an arbitrarily sorted vector `x`.
#'
#'   There is no specific handling of ties. It is assuming that in the case
#'   of ties for `x` that the vector you are re-indexing also has tied values
#'   thus the specific tied element selection does not matter.
#' @keywords internal
match_order <- function(x) {
    order(order(x))
}


#' Brier Score
#'
#' @inheritParams Brier-Score-Shared
#'
#' @description
#' Implements the Brier Score as detailed in \insertCite{blanche2015}{jmpost}
#'
#' @details
#' - `bs_get_squared_dist()` - implements the squared distance part
#' of the formula.
#' - `bs_get_weights()` - implements the IPCW weighting
#'
#' @references
#' \insertAllCited{}
#'
#' @keywords internal
brier_score <- function(
    t,
    times,
    events,
    pred_mat,
    maintain_cen_order = TRUE,
    event_offset = TRUE
) {
    square_diff_mat <- bs_get_squared_dist(
        t = t,
        times = times,
        events = events,
        pred_mat = pred_mat
    )

    weight_mat <- bs_get_weights(
        t = t,
        times = times,
        events = events,
        event_offset = event_offset,
        maintain_cen_order = maintain_cen_order
    )

    # the following is a computational shortcut for diag(A %*% B)
    # as we don't want to compute the off-diagonal entries of the
    # matrix multiplication
    x <- colSums(weight_mat * square_diff_mat)
    names(x) <- t
    x / length(times)
}


#' @rdname brier_score
bs_get_squared_dist <- function(t, times, events, pred_mat) {
    assert_numeric(
        times,
        finite = TRUE,
        any.missing = FALSE
    )
    assert_numeric(
        t,
        finite = TRUE,
        any.missing = FALSE
    )
    assert_numeric(
        events,
        finite = TRUE,
        any.missing = FALSE,
        lower = 0,
        upper = 1
    )
    assert_matrix(
        pred_mat,
        any.missing = FALSE,
        nrows = length(times),
        ncols = length(t)
    )
    assert_that(
        length(events) == length(times)
    )

    expected_mat <- mapply(
        \(ti, event) (ti <= t) * event * 1,
        ti = times,
        event = events,
        SIMPLIFY = FALSE
    ) |>
        unlist() |>
        matrix(ncol = length(t), byrow = TRUE)

    assert_that(
        nrow(pred_mat) == nrow(expected_mat),
        ncol(pred_mat) == ncol(expected_mat)
    )

    (expected_mat - pred_mat)^2
}


#' @rdname brier_score
bs_get_weights <- function(
    t,
    times,
    events,
    event_offset = TRUE,
    maintain_cen_order = TRUE
) {
    assert_numeric(
        times,
        finite = TRUE,
        any.missing = FALSE
    )
    assert_numeric(
        t,
        finite = TRUE,
        any.missing = FALSE
    )
    assert_numeric(
        events,
        finite = TRUE,
        any.missing = FALSE,
        lower = 0,
        upper = 1
    )
    assert_flag(event_offset, na.ok = FALSE, null.ok = FALSE)
    assert_flag(maintain_cen_order, na.ok = FALSE, null.ok = FALSE)
    n_col <- length(t)
    n_row <- length(times)

    reverse_km <- if (maintain_cen_order) {
        reverse_km_event_first
    } else {
        reverse_km_cen_first
    }
    offset <- if (event_offset) -.Machine$double.eps^(1 / 2) else 0

    censor_dist_t <- reverse_km(t, times, events)
    weight_mat_t <- 1 /
        matrix(
            rep(censor_dist_t$surv, n_row),
            nrow = n_row,
            byrow = TRUE
        )

    censor_dist_ti <- reverse_km(times + offset, times, events)
    weight_mat_ti <- 1 /
        matrix(
            rep(censor_dist_ti$surv, n_col),
            nrow = n_row
        )

    indicator_mat_t <- mapply(
        \(ti) (ti > t) * 1,
        ti = times,
        SIMPLIFY = FALSE
    ) |>
        unlist() |>
        matrix(ncol = n_col, byrow = TRUE)

    indicator_mat_ti <- mapply(
        \(ti, event) (ti <= t) * event * 1,
        ti = times,
        event = events,
        SIMPLIFY = FALSE
    ) |>
        unlist() |>
        matrix(ncol = n_col, byrow = TRUE)

    assert_that(
        all(indicator_mat_t + indicator_mat_ti <= 1)
    )

    weight_mat_t[indicator_mat_t == 0] <- 0
    weight_mat_ti[indicator_mat_ti == 0] <- 0

    (weight_mat_t + weight_mat_ti)
}

#' @include Grid.R
#' @include generics.R
NULL


#' @rdname Grid-Dev
.GridPrediction <- setClass(
    "GridPrediction",
    contains = "Grid",
    slots = c(
        "times" = "numeric_or_NULL",
        "newdata" = "data.frame",
        "params" = "list"
    )
)
#' @rdname Grid-Functions
#' @export
GridPrediction <- function(times = NULL, newdata, params = list()) {
    .GridPrediction(
        times = times,
        params = params,
        newdata = newdata
    )
}
setValidity(
    "GridPrediction",
    function(object) {
        for (param in names(object@params)) {
            if (length(object@params[[param]]) != 1) {
                return(sprintf("Parameter '%s' must be length 1", param))
            }
        }
        if (length(object@params) != length(names(object@params))) {
            return("All elements of `params` must be named")
        }
        if (!is.null(object@newdata[["..new_subject.."]])) {
            return(
                "`newdata` must not contain a column named '..new_subject..'"
            )
        }
        return(TRUE)
    }
)


#' @rdname Quant-Dev
#' @export
as.QuantityGenerator.GridPrediction <- function(object, data, ...) {
    assert_class(data, "DataJoint")
    data_list <- as.list(data)
    validate_time_grid(object@times)

    n_times <- length(object@times)
    n_obs <- nrow(object@newdata)
    newdata <- object@newdata
    newdata[["..new_subject.."]] <- sprintf(
        "new_subject_%i",
        seq_len(nrow(newdata))
    )

    QuantityGeneratorPrediction(
        times = rep(object@times, each = n_obs),
        newdata = replicate(newdata, n = n_times, simplify = FALSE) |>
            dplyr::bind_rows(),
        params = object@params
    )
}

#' @rdname Quant-Dev
#' @export
as.QuantityCollapser.GridPrediction <- function(object, data, ...) {
    assert_class(data, "DataJoint")
    data_list <- as.list(data)
    generator <- as.QuantityGenerator(object, data)
    QuantityCollapser(
        times = generator@times,
        groups = generator@newdata[["..new_subject.."]],
        indexes = as.list(seq_along(generator@times))
    )
}


#' @export
as.list.GridPrediction <- function(x, data, ...) {
    stop("`as.list()` is not implemented for `GridPrediction` objects")
}


#' @rdname coalesceGridTime
#' @export
coalesceGridTime.GridPrediction <- function(object, times, ...) {
    if (is.null(object@times)) {
        object <- GridPrediction(
            times = times,
            newdata = object@newdata,
            params = object@params
        )
    }
    object
}

#' @include SimLongitudinal.R
#' @include generics.R
NULL

#' Simulate Longitudinal Data from a GSF Model
#'
#' @typed times: numeric
#'   the times to generate observations at.
#' @typed sigma: number
#'   the variance of the longitudinal values.
#' @typed mu_s: numeric
#'   the mean shrinkage rates.
#' @typed mu_g: numeric
#'   the mean growth rates.
#' @typed mu_b: numeric
#'   the mean baseline values.
#' @typed mu_phi: numeric
#'   the mean proportion of cells affected by the treatment
#' @typed omega_b: number
#'   the baseline value standard deviation.
#' @typed omega_s: number
#'   the shrinkage rate standard deviation.
#' @typed omega_g: number
#'   the growth rate standard deviation.
#' @typed omega_phi: number
#'   for the standard deviation of the proportion of cells
#'   affected by the treatment `omega_phi`.
#' @typed link_dsld: number
#'   the link coefficient for the derivative contribution.
#' @typed link_ttg: number
#'   the link coefficient for the time-to-growth contribution.
#' @typed link_identity: number
#'   the link coefficient for the SLD Identity contribution.
#' @typed link_growth: number
#'   the link coefficient for the log-growth parameter contribution.
#' @typed link_shrinkage: number
#'   the link coefficient for the log-shrinkage parameter contribution.
#' @typed scaled_variance: logical
#'   whether the variance should be scaled by the expected value
#'   (see the "Statistical Specifications" vignette for more details)
#'
#' @slot sigma (`numeric`)\cr See arguments.
#' @slot mu_s (`numeric`)\cr See arguments.
#' @slot mu_g (`numeric`)\cr See arguments.
#' @slot mu_b (`numeric`)\cr See arguments.
#' @slot mu_phi (`numeric`)\cr See arguments.
#' @slot omega_b (`numeric`)\cr See arguments.
#' @slot omega_s (`numeric`)\cr See arguments.
#' @slot omega_g (`numeric`)\cr See arguments.
#' @slot omega_phi (`numeric`)\cr See arguments.
#' @slot link_dsld (`numeric`)\cr See arguments.
#' @slot link_ttg (`numeric`)\cr See arguments.
#' @slot link_identity (`numeric`)\cr See arguments.
#' @slot link_growth (`numeric`)\cr See arguments.
#' @slot link_shrinkage (`numeric`)\cr See arguments.
#' @slot scaled_variance (`numeric`)\cr See arguments.
#' @family SimLongitudinal
#' @name SimLongitudinalGSF-class
#' @exportClass SimLongitudinalGSF
.SimLongitudinalGSF <- setClass(
    "SimLongitudinalGSF",
    contains = "SimLongitudinal",
    slots = c(
        sigma = "numeric",
        mu_s = "numeric",
        mu_g = "numeric",
        mu_b = "numeric",
        mu_phi = "numeric",
        omega_b = "numeric",
        omega_s = "numeric",
        omega_g = "numeric",
        omega_phi = "numeric",
        link_dsld = "numeric",
        link_ttg = "numeric",
        link_identity = "numeric",
        link_growth = "numeric",
        link_shrinkage = "numeric",
        scaled_variance = "logical"
    )
)

#' @rdname SimLongitudinalGSF-class
#' @export
SimLongitudinalGSF <- function(
    times = c(-100, -50, 0, 50, 100, 150, 250, 350, 450, 550) / 365,
    sigma = 0.01,
    mu_s = log(c(0.6, 0.4)),
    mu_g = log(c(0.25, 0.35)),
    mu_b = log(60),
    mu_phi = qlogis(c(0.4, 0.6)),
    omega_b = 0.2,
    omega_s = 0.2,
    omega_g = 0.2,
    omega_phi = 0.2,
    link_dsld = 0,
    link_ttg = 0,
    link_identity = 0,
    link_growth = 0,
    link_shrinkage = 0,
    scaled_variance = TRUE
) {
    if (length(omega_b) == 1) {
        omega_b <- rep(omega_b, length(mu_b))
    }
    if (length(omega_s) == 1) {
        omega_s <- rep(omega_s, length(mu_s))
    }
    if (length(omega_g) == 1) {
        omega_g <- rep(omega_g, length(mu_g))
    }
    if (length(omega_phi) == 1) {
        omega_phi <- rep(omega_phi, length(mu_phi))
    }

    .SimLongitudinalGSF(
        times = times,
        sigma = sigma,
        mu_s = mu_s,
        mu_g = mu_g,
        mu_b = mu_b,
        mu_phi = mu_phi,
        omega_b = omega_b,
        omega_s = omega_s,
        omega_g = omega_g,
        omega_phi = omega_phi,
        link_dsld = link_dsld,
        link_ttg = link_ttg,
        link_identity = link_identity,
        link_growth = link_growth,
        link_shrinkage = link_shrinkage,
        scaled_variance = scaled_variance
    )
}


setValidity(
    "SimLongitudinalGSF",
    function(object) {
        par_lengths <- c(
            length(object@mu_s),
            length(object@mu_g),
            length(object@mu_phi)
        )
        if (length(unique(par_lengths)) != 1) {
            return(
                "The parameters `mu_s`, `mu_g` and `mu_phi` must have the same length."
            )
        }

        pairs <- list(
            "omega_b" = "mu_b",
            "omega_s" = "mu_s",
            "omega_g" = "mu_g",
            "omega_phi" = "mu_phi"
        )
        for (i in seq_along(pairs)) {
            omega <- slot(object, names(pairs)[[i]])
            mu <- slot(object, pairs[[i]])
            if (!(length(omega) == length(mu))) {
                return(
                    sprintf(
                        "`%s` must be length 1 or the same length as `%s`",
                        omega,
                        mu
                    )
                )
            }
        }

        len_1_pars <- c(
            "sigma",
            "link_dsld",
            "link_ttg",
            "link_identity",
            "link_growth",
            "link_shrinkage"
        )
        for (par in len_1_pars) {
            if (length(slot(object, par)) != 1) {
                return(sprintf(
                    "The `%s` parameter must be a length 1 numeric.",
                    par
                ))
            }
        }

        return(TRUE)
    }
)

#' @rdname as_print_string
#' @exportS3Method NULL
as_print_string.SimLongitudinalGSF <- function(object, ...) {
    return("SimLongitudinalGSF")
}

#' @rdname sampleObservations
#' @export
sampleObservations.SimLongitudinalGSF <- function(object, times_df) {
    times_df |>
        dplyr::mutate(
            mu_sld = gsf_sld(
                .data$time,
                .data$psi_b,
                .data$psi_s,
                .data$psi_g,
                .data$psi_phi
            ),
            dsld = gsf_dsld(
                .data$time,
                .data$psi_b,
                .data$psi_s,
                .data$psi_g,
                .data$psi_phi
            ),
            ttg = gsf_ttg(
                .data$time,
                .data$psi_b,
                .data$psi_s,
                .data$psi_g,
                .data$psi_phi
            ),
            sld_sd = ifelse(
                object@scaled_variance,
                .data$mu_sld * object@sigma,
                object@sigma
            ),
            sld = stats::rnorm(dplyr::n(), .data$mu_sld, .data$sld_sd),
            log_haz_link = (object@link_dsld * .data$dsld) +
                (object@link_ttg * .data$ttg) +
                (object@link_identity * .data$mu_sld) +
                (object@link_growth * log(.data$psi_g)) +
                (object@link_shrinkage * log(.data$psi_s))
        )
}


#' @rdname sampleSubjects
#' @export
sampleSubjects.SimLongitudinalGSF <- function(object, subjects_df) {
    assert_that(
        is.factor(subjects_df$study),
        is.factor(subjects_df$arm),
        length(levels(subjects_df$study)) == length(object@mu_b),
        length(levels(subjects_df$arm)) == length(object@mu_s),
        length(levels(subjects_df$arm)) == length(object@mu_g),
        length(levels(subjects_df$arm)) == length(object@mu_phi)
    )

    res <- subjects_df |>
        dplyr::distinct(.data$subject, .data$arm, .data$study) |>
        dplyr::mutate(
            study_idx = as.numeric(.data$study),
            arm_idx = as.numeric(.data$arm),
            psi_b = stats::rlnorm(
                dplyr::n(),
                object@mu_b[.data$study_idx],
                object@omega_b[.data$study_idx]
            ),
            psi_s = stats::rlnorm(
                dplyr::n(),
                object@mu_s[.data$arm_idx],
                object@omega_s[.data$arm_idx]
            ),
            psi_g = stats::rlnorm(
                dplyr::n(),
                object@mu_g[.data$arm_idx],
                object@omega_g[.data$arm_idx]
            ),
            psi_phi_logit = stats::rnorm(
                dplyr::n(),
                object@mu_phi[.data$arm_idx],
                object@omega_phi[.data$arm_idx]
            ),
            psi_phi = stats::plogis(.data$psi_phi_logit)
        )
    res[, c("subject", "arm", "study", "psi_b", "psi_s", "psi_g", "psi_phi")]
}


## sim_lm_gsf ----

#' Generalized Stein-Fojo Functionals
#'
#' @typed time: numeric
#'   time grid.
#' @typed b: number
#'   baseline.
#' @typed s: number
#'   shrinkage.
#' @typed g: number
#'   growth.
#' @typed phi: number
#'   shrinkage proportion.
#'
#' @returns The function results.
#'
#' @keywords internal
gsf_sld <- function(time, b, s, g, phi) {
    phi <- dplyr::if_else(time >= 0, phi, 0)
    b * (phi * exp(-s * time) + (1 - phi) * exp(g * time))
}


#' @rdname gsf_sld
gsf_ttg <- function(time, b, s, g, phi) {
    t1 <- (log(s * phi / (g * (1 - phi))) / (g + s))
    t1[t1 <= 0] <- 0
    return(t1)
}


#' @rdname gsf_sld
gsf_dsld <- function(time, b, s, g, phi) {
    phi <- dplyr::if_else(time >= 0, phi, 0)
    t1 <- (1 - phi) * g * exp(g * time)
    t2 <- phi * s * exp(-s * time)
    return(b * (t1 - t2))
}

#' Quantity Grid Specification
#'
#' @typed subjects: "`character` or `NULL`"
#'   vector of subjects to extract quantities for.
#'   If `NULL` will default to all subjects within the dataset.
#'
#' @typed times: "`numeric` or `NULL`"
#'   vector of time points to extract quantities at.
#'   If `NULL` will default to 201 evenly spaced timepoints between 0 and either the max
#' observation time (for [`LongitudinalQuantities`]) or max event time (for [`SurvivalQuantities`]).
#'
#' @typed groups: list
#'   named list of subjects to extract quantities for. See Group Specification.
#'
#' @typed spec: list
#'   named list of subjects to extract quantities for. The names of each
#'   element should be the required subjects with the element itself being a numeric vector of timepoints
#'   to generate the quantity at.
#'
#' @typed length.out: numeric
#'   number of evenly spaced timepoints to generate quantities at.
#'
#' @typed newdata: data.frame
#'   new data to generate quantities for. Must contain the same columns
#'   and factor levels of the original data used in the [`DataSurvival`] object.
#'
#' @typed params: list
#'   named list of parameters to fix the longitudinal model parameters at when
#'   predicting survival quantities. See [`getPredictionNames()`] for the required parameters.
#'
#' @description
#' These functions are used to specify which subjects and timepoints should be generated
#' when calculating quantities via [`SurvivalQuantities`] and [`LongitudinalQuantities`].
#'
#' @details
#'
#' - `GridFixed()` is used to specify a fixed set of timepoints to generate quantities at for
#' all the specified subjects.
#'
#' - `GridGrouped()` is similar to `GridFixed()` but allows for groupwise averaging
#' (see Group Specification).
#'
#' - `GridObserved()` generates quantities at the observed longitudinal timepoints for each
#' subject.
#'
#' - `GridManual()` allows for individual timepoint specification for each subject.
#'
#' - `GridEven()` generates quantities for each subject at N evenly spaced timepoints
#' between each subjects first and last longitudinal observations.
#'
#' - `GridEvent()` generates one quantity for each subject at their event/censor time
#' as indicated by the `time` variable in the survival dataset.
#'
#' - `GridPopulation()` generates longitudinal model quantities based on the population parameters at the
#' specified time points. Generates 1 set of quantities for each distinct combination of `arm`
#' and `study` within the [`DataSubject`] object provided to the [`JointModel`].
#'
#' - `GridPrediction()` generates survival quantities based on any user-defined values at the
#' specified time points. This is useful for generating quantities for a new dataset
#' on specific longitudinal model parameters. See [`getPredictionNames()`] to determine which
#' longitudinal model parameters need to be defined for a given longitudinal model.
#'
#' @section Group Specification:
#' For `GridGrouped()`, `groups` must be a named list of character vectors. Each element of the list
#' must be a character vector of the subjects that will form the group where the element name
#' is the corresponding name of the group. For example if the goal was to create two groups
#' named `Group-1` and `Group-2` which are composed of the subjects `sub-1`, `sub-2` and
#' `sub-3`, `sub-4` respectively then this would be specified as:
#' ```
#' GridGrouped(
#'     groups = list(
#'         "Group-1" = c("sub-1", "sub-2"),
#'         "Group-2" = c("sub-3", "sub-4")
#'     )
#'   )
#' ```
#' @seealso [`SurvivalQuantities`], [`LongitudinalQuantities`]
#' @name Grid-Functions
NULL


#' Grid Developer Notes
#'
#' @description
#' Developer details for implementing / extending `Grid` objects for defining
#' generated quantities for [`SurvivalQuantities`] and [`LongitudinalQuantities`].
#'
#' @slot subjects (`character` or `NULL`)\cr vector of subjects to extract quantities for.
#' If `NULL` will default to all subjects within the dataset.
#' @slot times (`numeric` or `NULL`)\cr vector of time points to extract quantities at.
#' If `NULL` will default to 201 evenly spaced timepoints between 0 and either the max
#' @slot groups (`list`)\cr named list of subjects to extract quantities for. See details.
#'
#' @details
#' All grid classes must inherit from the abstract `Grid` class.
#' All grid classes must provide `as.QuantityGenerator(object, data)` and
#' `as.QuantityCollapser(object, data)` methods where `data` is a [`DataJoint`] object.
#' These methods must return a `QuantityGenerator` and `QuantityCollapser` object respectively.
#' The `QuantityGenerator` object specifies unique subject/timepoint combinations that samples
#' should be generated at.
#' The `QuantityCollapser` object specifies how to combine these generated samples
#' to form the desired quantities.
#' As an example say we want to generate grouped samples for the groups `Group-1` and `Group-2`
#' which consist of the subjects `sub-1`, `sub-2` and `sub-3`, `sub-4` respectively at two time points
#' `10` and `20`. We can achieve this as follows:
#' ```
#' QuantityGenerator(
#'     times = c(10, 10, 10, 10, 20, 20, 20, 20),
#'     subjects = c("sub-1" "sub-2", "sub-3", "sub-4", "sub-1" "sub-2", "sub-3", "sub-4")
#'   )
#' QuantityCollapser(
#'     times = c(10, 20, 10 , 20),
#'     groups = c("Group-1", "Group-1", "Group-2", "Group-2"),
#'     indexes = list(c(1, 2), c(5, 6), c(3, 4), c(7, 8))
#'   )
#' ```
#' For population based quantities use the `arms` and `studies` arguments of `QuantityGenerator`
#' instead of `subjects`.
#'
#' @inheritSection Grid-Functions Group Specification
#'
#' @keywords internal
#' @seealso `Quant-Dev`
#' @name Grid-Dev
NULL


#' Quantity Developer Notes
#'
#' @description
#' Developer details for `QuantityX` objects/methods. This page just outlines the arguments
#' and slots of these objects/methods. For the full implementation details please see [Grid-Dev]
#'
#' @slot times (`numeric`)\cr See Arguments for details.
#' @slot subjects (`character`)\cr See Arguments for details.
#' @slot groups (`character`)\cr See Arguments for details.
#' @slot indexes (`list`)\cr See Arguments for details.
#'
#' @typed times: numeric
#'   vector of time points to extract quantities at.
#' @typed subjects: character
#'   vector of subjects to extract quantities for.
#' @typed groups: character
#'   vector of labels to apply to the generated quantities.
#' @typed indexes: list
#'   list of indexes that specify which observations from a
#'   `QuantityGenerator` should be combined to form the desired quantities.
#'
#' @typed object: Grid
#'   object to convert to a `QuantityGenerator` or `QuantityCollapser`.
#' @typed data: DataJoint
#'   Survival and Longitudinal Data.
#' @param ... Not currently used.
#'
#' @details
#' The `as.QuantityGenerator` must return a `QuantityGenerator` object.
#' The `as.QuantityCollapser` must return a `QuantityCollapser` object.
#' @keywords internal
#' @name Quant-Dev
NULL


#' @rdname Grid-Dev
.Grid <- setClass("Grid")


#' @rdname Quant-Dev
.QuantityGenerator <- setClass(
    "QuantityGenerator"
)
#' `QuantityGenerator` -> `list`
#' @description
#' Converts a `QuantityGenerator` object to a list containing the required input data for a stan
#' model.
#' @typed object: QuantityGenerator
#'   object to convert to a list.
#' @typed data: DataJoint
#'   Survival and Longitudinal Data.
#' @param ... Not currently used.
#' @keywords internal
#' @exportS3Method NULL
as_stan_list.QuantityGenerator <- function(object, data, ...) {
    stop("as_stan_list.QuantityGenerator not implemented")
}


#' @rdname Quant-Dev
.QuantityCollapser <- setClass(
    "QuantityCollapser",
    slots = c(
        "times" = "numeric",
        "groups" = "character",
        "indexes" = "list"
    )
)
#' @rdname Quant-Dev
QuantityCollapser <- function(times, groups, indexes) {
    .QuantityCollapser(
        times = times,
        groups = groups,
        indexes = indexes
    )
}

setValidity(
    "QuantityCollapser",
    function(object) {
        if (
            length(object@times) != length(object@groups) ||
                length(object@times) != length(object@indexes)
        ) {
            return("Length of `times`, `groups`, and `indexes` must be equal")
        }
    }
)

#' @export
length.QuantityCollapser <- function(x) {
    length(x@indexes)
}


#' Expand and Validate Subjects
#'
#' @typed subjects: character
#'   vector of subjects that should exist in `data`
#' @typed data: DataJoint
#'   Survival and Longitudinal Data.
#'
#' @description
#' If `subjects` is `NULL` this will return a named list of all subjects in `data`.
#' Else it will return `subjects` as a named list ensuring that all subjects exist in `data`.
#'
#' @keywords internal
subjects_to_list <- function(subjects = NULL, data) {
    data_list <- as.list(data)
    subjects_exp <- if (is.null(subjects)) {
        subs <- as.list(names(data_list$subject_to_index))
        names(subs) <- names(data_list$subject_to_index)
        subs
    } else {
        subs <- as.list(subjects)
        names(subs) <- subjects
        subs
    }
    subjects_exp_vec <- unlist(subjects_exp, use.names = FALSE)
    assert_that(
        identical(subjects_exp_vec, unique(subjects_exp_vec)),
        msg = "All subject names must be unique"
    )
    assert_that(
        all(subjects_exp_vec %in% names(data_list$subject_to_index)),
        msg = "Not all subjects exist within the data object"
    )
    subjects_exp
}

#' @include generics.R
#' @include utilities.R
NULL

#' Re-used documentation for `DataSurvival`
#'
#' @typed object: DataSurvival
#'   Survival Data.
#' @typed x: DataSurvival
#'   Survival Data.
#' @param ... Not Used.
#'
#' @name DataSurvival-Shared
#' @keywords internal
NULL


# DataSurvival-class ----

#' Survival Data Object and Constructor Function
#'
#' The [`DataSurvival`] class handles the processing of the survival data
#' for fitting a [`JointModel`].
#'
#' @slot data (`data.frame`)\cr See Arguments for details.
#' @slot formula (`formula`)\cr See Arguments for details.
#'
#' @family DataObjects
#' @family DataSurvival
#' @exportClass DataSurvival
#' @export DataSurvival
.DataSurvival <- setClass(
    Class = "DataSurvival",
    representation = list(
        data = "data.frame",
        formula = "formula"
    )
)

#' @typed data: data.frame
#'   the observed time-to-event data.
#' @typed formula: formula
#'   of the form `Surv(time, event) ~ cov1 + cov2 + ...`.
#'   See [survival::Surv()] for more details, though note that this package only supports right censoring.
#' @rdname DataSurvival-class
DataSurvival <- function(data, formula) {
    .DataSurvival(
        data = remove_missing_rows(data, formula),
        formula = formula
    )
}

setValidity(
    "DataSurvival",
    method = function(object) {
        dat <- object@data
        x <- extractVariableNames(object)
        dnames <- names(dat)
        if (nrow(object@data) == 0) {
            return("`data` should not have 0 rows")
        }
        if (length(x$frm) != 3) {
            return("`formula` should be a 2 sided formula")
        }
        LHS <- as.character(x$frm[[2]][[1]])
        lhs_surv <- identical(LHS, "Surv")
        lhs_colon_surv <- identical(LHS, c("::", "survival", "Surv"))
        if (!(lhs_surv || lhs_colon_surv)) {
            return("The LHS of `formula` should be a call to survival::Surv()")
        }
        for (v in c(x$time, x$event)) {
            if (!v %in% dnames) {
                return(sprintf("Variable %s is not in `data`", x$subject))
            }
        }
        return(TRUE)
    }
)


#' @inheritParams DataSurvival-Shared
#' @inherit extractVariableNames description title
#'
#' @returns
#' A list with the following named elements:
#' - `frm` (`formula`)\cr a symbolic description of the survival model to be fitted
#' - `time` (`character`)\cr  The name of the variable containing the event time
#' - `event` (`character`) \cr  The name of the variable containing the event status
#' @export
#' @family DataSurvival
#' @family extractVariableNames
#' @keywords internal
extractVariableNames.DataSurvival <- function(object) {
    list(
        frm = object@formula,
        time = as.character(object@formula[[2]][[2]]),
        event = as.character(object@formula[[2]][[3]])
    )
}


#' `DataSurvival` -> `data.frame`
#'
#' @inheritParams DataSurvival-Shared
#'
#' @description
#' Converts a [`DataSurvival`] object into a `data.frame`.
#' The subject variable is cast to factor.
#' @family DataSurvival
#' @export
as.data.frame.DataSurvival <- function(x, ...) {
    x <- x@data
    rownames(x) <- NULL
    x
}


#' @rdname as_stan_list.DataObject
#' @family DataSurvival
#' @export
as_stan_list.DataSurvival <- function(object, ...) {
    df <- as.data.frame(object)
    vars <- extractVariableNames(object)

    design_mat <- stats::model.matrix(vars$frm, data = df)
    remove_index <- grep("(Intercept)", colnames(design_mat), fixed = TRUE)
    design_mat <- design_mat[, -remove_index, drop = FALSE]
    rownames(design_mat) <- NULL

    # Parameters for efficient integration of hazard function -> survival function
    gh_parameters <- statmod::gauss.quad(
        n = getOption("jmpost.gauss_quad_n"),
        kind = "legendre"
    )

    model_data <- list(
        n_subject_event = sum(df[[vars$event]]),
        subject_event_index = which(df[[vars$event]] == 1),
        event_times = df[[vars$time]],
        p_os_cov_design = ncol(design_mat),
        os_cov_design = design_mat,
        n_nodes = length(gh_parameters$nodes),
        nodes = gh_parameters$nodes,
        weights = gh_parameters$weights
    )
    return(model_data)
}

#' @rdname as_stan_list.DataObject
#' @export
as.list.DataSurvival <- function(x, ...) {
    as_stan_list(x, ...)
}

#' @rdname harmonise
#' @exportS3Method NULL
harmonise.DataSurvival <- function(object, subject_var, subject_ord, ...) {
    data <- as.data.frame(object)

    assert_string(subject_var, na.ok = FALSE)
    assert_character(subject_ord, any.missing = FALSE)
    assert_that(
        subject_var %in% names(data),
        msg = sprintf(
            "Subject variable `%s` not found in `survival`",
            subject_var
        )
    )
    assert_that(
        all(data[[subject_var]] %in% subject_ord),
        msg = "There are subjects in `survival` that are not present in `subjects`"
    )
    assert_that(
        all(subject_ord %in% data[[subject_var]]),
        msg = "There are subjects in `subjects` that are not present in `survival`"
    )

    data[[subject_var]] <- factor(
        as.character(data[[subject_var]]),
        levels = subject_ord
    )

    data_ord <- data[order(data[[subject_var]]), ]

    DataSurvival(
        data = data_ord,
        formula = object@formula
    )
}


#' `DataSurvival` -> Printable `Character`
#'
#' Converts [`DataSurvival`] object into a printable string.
#' @inheritParams DataSurvival-Shared
#' @family DataSurvival
#' @typed indent: numeric
#'   how much white space to prefix the print string with.
#' @keywords internal
#' @export
as_print_string.DataSurvival <- function(object, indent = 1, ...) {
    template <- c(
        "Survival-Data Object:",
        "    # of Rows     = %d",
        "    # of Columns  = %d",
        "    # of Events   = %d",
        "    Formula       = %s"
    )
    pad <- rep(" ", indent) |> paste(collapse = "")
    template_padded <- paste(pad, template)
    vars <- extractVariableNames(object)
    sprintf(
        paste(template_padded, collapse = "\n"),
        nrow(object@data),
        ncol(object@data),
        sum(object@data[[vars$event]]),
        Reduce(paste, deparse(vars$frm))
    )
}

#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "DataSurvival",
    definition = function(object) {
        string <- as_print_string(object)
        cat("\n", string, "\n\n")
    }
)

#' Build design matrix for prediction data
#'
#' @description
#' This function takes a `DataSurvival` object and a `data.frame` object and generates
#' a design matrix for the `data.frame` that has the identical structure to the
#' design matrix of the `DataSurvival` object.
#'
#' This is used for predicting new data using a model that was trained on a different
#' original data source
#'
#' @typed olddata: DataSurvival
#'   The original data to be used as a template for the new data
#' @typed newdata: data.frame
#'   The new data to be used to generate the design matrix
#' @importFrom stats .checkMFClasses terms delete.response model.frame model.matrix
#' @importFrom survival coxph
#' @keywords internal
mirror_design_matrix <- function(olddata, newdata) {
    frm <- as_formula(olddata)
    # Dummy model to generate a bunch of meta information that we can use to
    # re-construct the design matrix
    model <- coxph(data = as.data.frame(olddata), formula = frm)
    model_terms <- delete.response(terms(model))
    model_frame <- model.frame(
        model_terms,
        newdata,
        xlev = model$xlevels
    )
    if (!is.null(data_classes <- attr(model_terms, "dataClasses"))) {
        .checkMFClasses(data_classes, model_frame)
    }
    design_mat <- model.matrix(
        model_terms,
        model_frame,
        contrasts.arg = model$contrasts
    )
    remove_index <- grep("(Intercept)", colnames(design_mat), fixed = TRUE)
    design_mat <- design_mat[, -remove_index, drop = FALSE]
    rownames(design_mat) <- NULL
    design_mat
}


#' @export
as_formula.DataSurvival <- function(x, ...) {
    vars <- extractVariableNames(x)
    vars$frm
}

#' @include DataJoint.R
#' @include Quantities.R
NULL


#' Re-used documentation for `LongitudinalQuantities`
#'
#' @typed x: LongitudinalQuantities
#'   longitudinal quantities.
#' @typed object: LongitudinalQuantities
#'   longitudinal quantities.
#' @param ... not used.
#'
#' @keywords internal
#' @name LongitudinalQuantities-Shared
NULL


#' `LongitudinalQuantities` Object & Constructor Function
#'
#' Constructor function to generate a `LongitudinalQuantities` object.
#'
#' @details
#' Note that unlike [`SurvivalQuantities`], [`LongitudinalQuantities`] does not support
#' group aggregation.
#'
#' @slot quantities (`Quantities`)\cr The sampled quantities. Should contain 1 element per
#' element of `group`
#'
#' @slot data (`DataJoint`)\cr Survival and Longitudinal Data.
#'
#' @family LongitudinalQuantities
#' @name LongitudinalQuantities-class
#' @export LongitudinalQuantities
.LongitudinalQuantities <- setClass(
    "LongitudinalQuantities",
    slots = c(
        "quantities" = "Quantities",
        "data" = "DataJoint"
    )
)

#' @typed object: JointModelSamples
#'   samples as drawn from a Joint Model.
#'
#' @typed grid: Grid
#'   object that specifies which subjects and time points to calculate the
#'   quantities for. See [Grid-Functions].
#' @rdname LongitudinalQuantities-class
LongitudinalQuantities <- function(
    object,
    grid
) {
    assert_class(object, "JointModelSamples")
    assert_class(grid, "Grid")
    assert_that(
        !is(grid, "GridPrediction"),
        msg = "`GridPrediction` objects are not supported for `LongitudinalQuantities`"
    )

    time_grid <- seq(
        from = 0,
        to = max(as.list(object@data)[["tumour_time"]]),
        length = 201
    )

    grid <- coalesceGridTime(grid, time_grid)

    gq <- generateQuantities(
        object,
        generator = as.QuantityGenerator(grid, object@data),
        type = "longitudinal"
    )

    quantities_raw <- extract_quantities(gq, type = "lm_identity")

    collapser <- as.QuantityCollapser(grid, object@data)
    quantities <- collapse_quantities(quantities_raw, collapser)

    .LongitudinalQuantities(
        quantities = Quantities(
            quantities,
            groups = collapser@groups,
            times = collapser@times
        ),
        data = object@data
    )
}


#' `as.data.frame`
#'
#' @typed x: LongitudinalQuantities
#'   longitudinal quantities.
#' @param ... not used.
#' @family LongitudinalQuantities
#' @export
as.data.frame.LongitudinalQuantities <- function(x, ...) {
    as.data.frame(x@quantities)
}


#' summary
#'
#' @description
#' This method returns a `data.frame` of the longitudinal quantities.
#'
#' @typed conf.level: numeric
#'   confidence level of the interval.
#' @inheritParams LongitudinalQuantities-Shared
#'
#' @family LongitudinalQuantities
#' @family summary
#' @export
summary.LongitudinalQuantities <- function(
    object,
    conf.level = 0.95,
    ...
) {
    summary(object@quantities, conf.level = conf.level)
}


#' Longitudinal Plot
#'
#' Internal plotting function to create longitudinal plots
#' This function predominately exists to extract core logic into its own function
#' to enable easier unit testing.
#'
#' @typed data: data.frame
#'   summary statistics for longitudinal
#'   value estimates. See details.
#' @typed data_obs: data.frame
#'   real observed values to be
#'   overlaid for reference.  See details.
#' @typed add_ci: logical
#'   Should confidence intervals be added? Default = `TRUE`.
#' @details
#'
#' ## `data`
#' Should contain the following columns:
#' - `time` (`numeric`) \cr time point for the summary statistic.
#' - `group` (`character`) \cr the group in which the observation belongs to.
#' - `median` (`numeric`) \cr the median value for the summary statistic.
#' - `upper` (`numeric`) \cr the upper 95% CI for the summary statistic.
#' - `lower` (`numeric`) \cr the lower 95% CI for the summary statistic.
#'
#' ## `data_obs`
#' Should contain the following columns:
#' - `time` (`numeric`) \cr the time at which the observed value occurred.
#' - `Yob` (`numeric`) \cr the real observed value.
#' - `group` (`character`) \cr which group the event belongs to, should correspond to
#' values in `data$group`.
#' @keywords internal
longitudinal_plot <- function(
    data,
    data_obs = NULL,
    add_ci = FALSE
) {
    p <- ggplot() +
        geom_line(aes(x = .data$time, y = .data$median), data = data) +
        xlab(expression(t)) +
        ylab(expression(y)) +
        facet_wrap(~group) +
        theme_bw()

    if (add_ci) {
        p <- p +
            geom_ribbon(
                aes(x = .data$time, ymin = .data$lower, ymax = .data$upper),
                data = data,
                alpha = 0.3
            )
    }

    if (!is.null(data_obs)) {
        p <- p + geom_point(aes(x = .data$time, y = .data$Yob), data = data_obs)
    }
    return(p)
}


#' Automatic Plotting for `LongitudinalQuantities`
#'
#' @typed conf.level: numeric
#'   confidence level of the interval. If values of `FALSE`,
#'   `NULL` or `0` are provided then confidence regions will not be added to the plot.
#' @inheritParams LongitudinalQuantities-Shared
#'
#' @family LongitudinalQuantities
#' @family autoplot
#' @export
autoplot.LongitudinalQuantities <- function(object, conf.level = 0.95, ...) {
    include_ci <- !is.null(conf.level) &&
        is.numeric(conf.level) &&
        conf.level > 0
    # If CI aren't needed supply a default 0.95 to summary function as it needs
    # a value to be specified to work.
    conf.level <- if (include_ci) conf.level else 0.95
    data_sum <- summary(object, conf.level = conf.level)
    data_obs <- extract_observed_values(object@data)
    assert_that(
        "group" %in% names(data_sum),
        "subject" %in% names(data_obs)
    )
    data_obs$group <- data_obs$subject
    data_obs <- data_obs[data_obs$group %in% data_sum$group, ]
    longitudinal_plot(
        data = data_sum,
        data_obs = data_obs,
        add_ci = include_ci
    )
}


#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "LongitudinalQuantities",
    definition = function(object) {
        template <- c(
            "LongitudinalQuantities Object:",
            "    # of samples    = %d",
            "    # of quantities = %d"
        )
        string <- sprintf(
            paste(template, collapse = "\n"),
            nrow(object@quantities),
            ncol(object@quantities)
        )
        cat("\n", string, "\n\n")
    }
)

#' @include SimLongitudinal.R
#' @include generics.R
NULL

#' Simulate Longitudinal Data from a Claret-Bruno Model
#'
#' @typed times: numeric
#'   the times to generate observations at.
#' @typed sigma: number
#'   the variance of the longitudinal values.
#'
#' @typed mu_b: numeric
#'   the mean population baseline sld value.
#' @typed mu_g: numeric
#'   the mean population growth rate.
#' @typed mu_c: numeric
#'   the mean population resistance rate.
#' @typed mu_p: numeric
#'   the mean population growth inhibition.
#'
#' @typed omega_b: number
#'   the population standard deviation for the baseline sld value.
#' @typed omega_g: number
#'   the population standard deviation for the growth rate.
#' @typed omega_c: number
#'   the population standard deviation for the resistance rate.
#' @typed omega_p: number
#'   the population standard deviation for the growth inhibition.
#'
#' @typed link_dsld: number
#'   the link coefficient for the derivative contribution.
#' @typed link_ttg: number
#'   the link coefficient for the time-to-growth contribution.
#' @typed link_identity: number
#'   the link coefficient for the SLD Identity contribution.
#' @typed link_growth: number
#'   the link coefficient for the growth parameter contribution.
#'
#' @typed scaled_variance: logical
#'   whether the variance should be scaled by the expected value
#'   (see the "Statistical Specifications" vignette for more details)
#'
#' @slot sigma (`numeric`)\cr See arguments.
#'
#' @slot mu_b (`numeric`)\cr See arguments.
#' @slot mu_g (`numeric`)\cr See arguments.
#' @slot mu_c (`numeric`)\cr See arguments.
#' @slot mu_p (`numeric`)\cr See arguments.
#'
#' @slot omega_b (`numeric`)\cr See arguments.
#' @slot omega_g (`numeric`)\cr See arguments.
#' @slot omega_c (`numeric`)\cr See arguments.
#' @slot omega_p (`numeric`)\cr See arguments.
#'
#' @slot link_dsld (`numeric`)\cr See arguments.
#' @slot link_ttg (`numeric`)\cr See arguments.
#' @slot link_identity (`numeric`)\cr See arguments.
#' @slot link_growth (`numeric`)\cr See arguments.
#'
#' @slot scaled_variance (`logical`)\cr See arguments.
#'
#' @family SimLongitudinal
#' @name SimLongitudinalClaretBruno-class
#' @exportClass SimLongitudinalClaretBruno
.SimLongitudinalClaretBruno <- setClass(
    "SimLongitudinalClaretBruno",
    contains = "SimLongitudinal",
    slots = c(
        sigma = "numeric",
        mu_b = "numeric",
        mu_g = "numeric",
        mu_c = "numeric",
        mu_p = "numeric",
        omega_b = "numeric",
        omega_g = "numeric",
        omega_c = "numeric",
        omega_p = "numeric",
        link_dsld = "numeric",
        link_ttg = "numeric",
        link_identity = "numeric",
        link_growth = "numeric",
        scaled_variance = "logical"
    )
)

#' @rdname SimLongitudinalClaretBruno-class
#' @export
SimLongitudinalClaretBruno <- function(
    times = c(-100, -50, 0, 50, 100, 150, 250, 350, 450, 550) / 365,
    sigma = 0.01,
    mu_b = log(60),
    mu_g = log(c(0.9, 1.1)),
    mu_c = log(c(0.25, 0.35)),
    mu_p = log(c(1.5, 2)),
    omega_b = 0.2,
    omega_g = 0.2,
    omega_c = 0.2,
    omega_p = 0.2,
    link_dsld = 0,
    link_ttg = 0,
    link_identity = 0,
    link_growth = 0,
    scaled_variance = TRUE
) {
    if (length(omega_b) == 1) {
        omega_b <- rep(omega_b, length(mu_b))
    }
    if (length(omega_g) == 1) {
        omega_g <- rep(omega_g, length(mu_g))
    }
    if (length(omega_c) == 1) {
        omega_c <- rep(omega_c, length(mu_c))
    }
    if (length(omega_p) == 1) {
        omega_p <- rep(omega_p, length(mu_p))
    }

    .SimLongitudinalClaretBruno(
        times = times,
        sigma = sigma,
        mu_b = mu_b,
        mu_g = mu_g,
        mu_c = mu_c,
        mu_p = mu_p,
        omega_b = omega_b,
        omega_g = omega_g,
        omega_c = omega_c,
        omega_p = omega_p,
        link_dsld = link_dsld,
        link_ttg = link_ttg,
        link_identity = link_identity,
        link_growth = link_growth,
        scaled_variance = scaled_variance
    )
}


setValidity(
    "SimLongitudinalClaretBruno",
    function(object) {
        par_lengths <- c(
            length(object@mu_g),
            length(object@mu_c),
            length(object@mu_p)
        )
        if (length(unique(par_lengths)) != 1) {
            return(
                "The parameters `mu_g`, `mu_c` & `mu_p` must have the same length."
            )
        }
        pairs <- list(
            "omega_b" = "mu_b",
            "omega_g" = "mu_g",
            "omega_c" = "mu_c",
            "omega_p" = "mu_p"
        )
        for (i in seq_along(pairs)) {
            omega <- slot(object, names(pairs)[[i]])
            mu <- slot(object, pairs[[i]])
            if (!(length(omega) == length(mu))) {
                return(
                    sprintf(
                        "`%s` must be length 1 or the same length as `%s`",
                        omega,
                        mu
                    )
                )
            }
        }
        len_1_pars <- c(
            "sigma",
            "link_dsld",
            "link_ttg",
            "link_identity",
            "link_growth"
        )
        for (par in len_1_pars) {
            if (length(slot(object, par)) != 1) {
                return(sprintf(
                    "The `%s` parameter must be a length 1 numeric.",
                    par
                ))
            }
        }
        return(TRUE)
    }
)

#' @rdname as_print_string
#' @exportS3Method NULL
as_print_string.SimLongitudinalClaretBruno <- function(object, ...) {
    return("SimLongitudinalClaretBruno")
}

#' @rdname sampleObservations
#' @export
sampleObservations.SimLongitudinalClaretBruno <- function(object, times_df) {
    times_df |>
        dplyr::mutate(
            mu_sld = clbr_sld(
                .data$time,
                .data$ind_b,
                .data$ind_g,
                .data$ind_c,
                .data$ind_p
            ),
            dsld = clbr_dsld(
                .data$time,
                .data$ind_b,
                .data$ind_g,
                .data$ind_c,
                .data$ind_p
            ),
            ttg = clbr_ttg(
                .data$time,
                .data$ind_b,
                .data$ind_g,
                .data$ind_c,
                .data$ind_p
            ),
            sld_sd = ifelse(
                object@scaled_variance,
                .data$mu_sld * object@sigma,
                object@sigma
            ),
            sld = stats::rnorm(dplyr::n(), .data$mu_sld, .data$sld_sd),

            log_haz_link = (object@link_dsld * .data$dsld) +
                (object@link_ttg * .data$ttg) +
                (object@link_identity * .data$mu_sld) +
                (object@link_growth * log(.data$ind_g))
        )
}


#' @rdname sampleSubjects
#' @export
sampleSubjects.SimLongitudinalClaretBruno <- function(object, subjects_df) {
    assert_that(
        is.factor(subjects_df$study),
        is.factor(subjects_df$arm),
        length(levels(subjects_df$study)) == length(object@mu_b),
        length(levels(subjects_df$arm)) == length(object@mu_g),
        length(levels(subjects_df$arm)) == length(object@mu_c),
        length(levels(subjects_df$arm)) == length(object@mu_p)
    )

    res <- subjects_df |>
        dplyr::distinct(.data$subject, .data$arm, .data$study) |>
        dplyr::mutate(study_idx = as.numeric(.data$study)) |>
        dplyr::mutate(arm_idx = as.numeric(.data$arm)) |>
        dplyr::mutate(
            ind_b = stats::rlnorm(
                dplyr::n(),
                object@mu_b[.data$study_idx],
                object@omega_b[.data$study_idx]
            )
        ) |>
        dplyr::mutate(
            ind_g = stats::rlnorm(
                dplyr::n(),
                object@mu_g[.data$arm_idx],
                object@omega_g[.data$arm_idx]
            )
        ) |>
        dplyr::mutate(
            ind_c = stats::rlnorm(
                dplyr::n(),
                object@mu_c[.data$arm_idx],
                object@omega_c[.data$arm_idx]
            )
        ) |>
        dplyr::mutate(
            ind_p = stats::rlnorm(
                dplyr::n(),
                object@mu_p[.data$arm_idx],
                object@omega_p[.data$arm_idx]
            )
        )

    res[, c("subject", "arm", "study", "ind_b", "ind_g", "ind_c", "ind_p")]
}


#' Claret-Bruno Functionals
#'
#' @typed t: numeric
#'   time grid.
#' @typed b: number
#'   baseline sld.
#' @typed g: number
#'   growth rate.
#' @typed c: number
#'   resistance rate.
#' @typed p: number
#'   growth inhibition.
#'
#' @returns The function results.
#' @keywords internal
clbr_sld <- function(t, b, g, c, p) {
    p <- ifelse(t >= 0, p, 0)
    b * exp((g * t) - (p / c) * (1 - exp(-c * t)))
}

#' @rdname clbr_sld
clbr_ttg <- function(t, b, g, c, p) {
    log(p / g) / c
}

#' @rdname clbr_sld
clbr_dsld <- function(t, b, g, c, p) {
    lt0 <- b * g * exp(g * t)
    gt0 <- (g - p * exp(-c * t)) * clbr_sld(t, b, g, c, p)
    ifelse(t >= 0, gt0, lt0)
}

#' @include generics.R
NULL

# STAN_BLOCKS ----

#' List of Stan Blocks
#'
#' @description
#' A list with 1 element per standard Stan program blocks.
#' This object is  mostly used internally as a reference for
#' what blocks are expected to exist within a given Stan program.
#'
#' @export
STAN_BLOCKS <- list(
    functions = "functions",
    data = "data",
    transformed_data = "transformed data",
    parameters = "parameters",
    transformed_parameters = "transformed parameters",
    model = "model",
    generated_quantities = "generated quantities"
)

# add_missing_stan_blocks ----

#' Add Missing Stan Blocks
#'
#' @typed x: list
#'   list of Stan code blocks
#' @typed stan_blocks: list
#'   reference list of stan blocks.
#'
#' @return Amended list `x` such that all blocks in the global variable
#' `STAN_BLOCKS` are contained.
#'
#' @keywords internal
add_missing_stan_blocks <- function(x, stan_blocks = STAN_BLOCKS) {
    for (block in names(stan_blocks)) {
        if (is.null(x[[block]])) {
            x[[block]] <- ""
        }
    }
    return(x)
}

# StanModule-class ----

#' `StanModule` Object and Constructor Function
#'
#' @typed x: string
#'   file path to a Stan program or a character vector
#'   of Stan code to be parsed.
#' @param ... additional arguments passed to the constructor.
#'
#' @slot functions (`character`)\cr the `functions` block.
#' @slot data (`character`)\cr the `data` block.
#' @slot transformed_data (`character`)\cr the `transformed_data` block.
#' @slot parameters (`character`)\cr the `parameters` block.
#' @slot transformed_parameters (`character`)\cr the `transformed_parameters` block.
#' @slot model (`character`)\cr the `model` block.
#' @slot generated_quantities (`character`)\cr the `generated_quantities` block.
#'
#' @exportClass StanModule
#' @export StanModule
#' @family StanModule
.StanModule <- setClass(
    Class = "StanModule",
    slots = list(
        functions = "character",
        data = "character",
        transformed_data = "character",
        parameters = "character",
        transformed_parameters = "character",
        model = "character",
        generated_quantities = "character"
    )
)

# StanModule-constructors ----

#' @rdname StanModule-class
StanModule <- function(
    x = "",
    ...
) {
    assert_that(
        is.character(x),
        length(x) == 1,
        msg = "`x` must be a length 1 character vector"
    )
    code <- read_stan(x)
    code_fragments <- as_stan_fragments(code)

    if (
        paste0(unlist(code_fragments), collapse = "") == "" &&
            paste0(x, collaspe = "") != ""
    ) {
        warning(
            "Non-empty input resulted in an empty StanModule object. Is the input correct?"
        )
    }

    .StanModule(
        functions = code_fragments$functions,
        data = code_fragments$data,
        transformed_data = code_fragments$transformed_data,
        parameters = code_fragments$parameters,
        transformed_parameters = code_fragments$transformed_parameters,
        model = code_fragments$model,
        generated_quantities = code_fragments$generated_quantities,
        ...
    )
}

# as.character-StanModule ----

#' `StanModule` -> `character`
#' @typed x: StanModule
#'   A stan program
#' @param ... Not Used.
#' @description
#' Converts a [`StanModule`] object into a valid Stan program file where each
#' line of the returned `character` vector represents a line of the program
#' @family StanModule
#' @export
as.character.StanModule <- function(x, ...) {
    as_stan_file(
        functions = x@functions,
        data = x@data,
        transformed_data = x@transformed_data,
        parameters = x@parameters,
        transformed_parameters = x@transformed_parameters,
        model = x@model,
        generated_quantities = x@generated_quantities
    )
}


# merge-StanModule,StanModule ----

#' @typed stan_blocks: list
#'   reference list of stan blocks.
#' @rdname merge
setMethod(
    f = "merge",
    signature = c("StanModule", "StanModule"),
    definition = function(x, y, stan_blocks = STAN_BLOCKS, ...) {
        stan_fragments <- lapply(
            names(stan_blocks),
            \(par) {
                if (all(slot(y, par) == "")) {
                    return(slot(x, par))
                }
                if (all(slot(x, par) == "")) {
                    return(slot(y, par))
                }
                return(c(slot(x, par), slot(y, par)))
            }
        )
        names(stan_fragments) <- names(stan_blocks)
        stan_code <- do.call(as_stan_file, stan_fragments)
        StanModule(
            x = stan_code
        )
    }
)

# compileStanModel-StanModule,character ----

#' @rdname compileStanModel
#' @exportS3Method NULL
compileStanModel.StanModule <- function(object) {
    exe_dir <- getOption("jmpost.cache_dir")
    if (!dir.exists(exe_dir)) {
        dir.create(exe_dir, recursive = TRUE)
    }
    stan_code <- as.character(object)
    hash_name <- digest::digest(stan_code, "md5")
    exe_name <- paste0(
        "model_",
        hash_name,
        if (is_windows()) ".exe" else ""
    )
    exe_file <- file.path(exe_dir, exe_name)
    source_file <- cmdstanr::write_stan_file(
        code = stan_code,
        dir = exe_dir,
        basename = sprintf("model_%s.stan", hash_name)
    )

    # Suppress "model executable is up to date" message as
    # users are not in control of the cache so this message is meaningless
    withCallingHandlers(
        {
            x <- cmdstanr::cmdstan_model(
                stan_file = source_file,
                exe_file = exe_file,
                quiet = TRUE
            )
        },
        message = function(m) {
            if (m$message == "Model executable is up to date!\n") {
                invokeRestart("muffleMessage")
            }
        }
    )
    invisible(x)
}


# as.list-StanModule ----

#' `StanModule` -> `list`
#' @description
#' Returns a named list where each element of the list corresponds
#' to a Stan modelling block e.g. `data`, `model`, etc.
#' @typed x: StanModule
#'   A Stan Module
#' @typed stan_blocks: list
#'   reference list of stan blocks.
#' @param ... Not Used.
#' @family StanModule
#' @export
as.list.StanModule <- function(x, stan_blocks = STAN_BLOCKS, ...) {
    string <- as.character(x)
    li <- as_stan_fragments(string)
    for (block in names(stan_blocks)) {
        li[[block]] <- paste(li[[block]], collapse = "\n")
    }
    return(li)
}

# is_file ----

#' Is String a Valid File?
#'
#' A utility function to check if a string is a valid file or not.
#' Used to help address short comings of [file.exists()] that will return `TRUE`
#' for a directory as well as a file.
#'
#' @typed filename: string
#'   file name.
#'
#' @keywords internal
is_file <- function(filename = NULL) {
    if (is.null(filename)) {
        return(FALSE)
    }
    assert_that(
        is.character(filename),
        length(filename) == 1,
        msg = "`filename` must be a length 1 character"
    )
    if (nchar(filename) > 1000) {
        return(FALSE)
    }
    if (is.na(filename)) {
        return(FALSE)
    }
    return(file.exists(filename) & !dir.exists(filename))
}

# read_stan ----

#' Stan Code as Character
#'
#' @param string Character, either the absolute path of a stan file, or the name of the stan
#' file in the package directory or the stan code as a string.
read_stan <- function(string) {
    local_inst_file <- file.path("inst", "stan", string)
    system_file <- system.file(file.path("stan", string), package = "jmpost")
    local_file <- string
    files <- c(local_file, local_inst_file, system_file)
    for (fi in files) {
        if (is_file(fi)) {
            string <- readLines(fi)
            break
        }
    }
    string <- paste0(string, collapse = "\n")
    return(string)
}

# as_stan_file ----

#' Merging Code Blocks into Stan Code Character Vector
#'
#' @typed functions: character
#'   code block.
#' @typed data: character
#'   code block.
#' @typed transformed_data: character
#'   code block.
#' @typed parameters: character
#'   code block.
#' @typed transformed_parameters: character
#'   code block.
#' @typed model: character
#'   code block.
#' @typed generated_quantities: character
#'   code block.
#' @typed stan_blocks: list
#'   reference list of stan blocks.
#'
#' @return Character vector of the complete Stan code.
#'
#' @keywords internal
as_stan_file <- function(
    functions = "",
    data = "",
    transformed_data = "",
    parameters = "",
    transformed_parameters = "",
    model = "",
    generated_quantities = "",
    stan_blocks = STAN_BLOCKS
) {
    block_strings <- lapply(
        names(stan_blocks),
        function(id) {
            char <- get(id)
            if (any(nchar(char) >= 1)) {
                return(sprintf(
                    "%s {\n%s\n}\n\n",
                    stan_blocks[[id]],
                    paste(char, collapse = "\n")
                ))
            } else {
                return("")
            }
        }
    )
    return(paste0(block_strings, collapse = ""))
}

# as_stan_fragments ----

#' Conversion of Character Vector into Stan Code Block List
#'
#' @typed x: character
#'   the single Stan code vector.
#' @typed stan_blocks: list
#'   reference list of stan blocks.
#'
#' @return A list with the Stan code blocks.
#'
#' @details
#' Function only works if code is in format
#' ```
#' data {
#'     <code>
#'   }
#' model {
#'     <code>
#'   }
#' ```
#' That is to say we do not support code in inline format i.e.
#' ```
#' data { <code> }
#' model { <code> }
#' ```
#'
#' @keywords internal
as_stan_fragments <- function(x, stan_blocks = STAN_BLOCKS) {
    code <- unlist(stringr::str_split(x, "\n"))

    errmsg <- paste(
        "There were problems parsing the `%s` block.",
        "Please consult the `Formatting Stan Files` section of the",
        "`Extending jmpost` vignette"
    )

    # Check to see if any block openings exist that have code on the same line
    # e.g.  `data { int i;}`. This is unsupported so we throw an error
    for (block in stan_blocks) {
        regex <- sprintf("^\\s*%s\\s*\\{\\s*[^\\s-]+", block)
        if (any(grepl(regex, code, perl = TRUE))) {
            stop(sprintf(errmsg, block))
        }
    }

    # We first look to identify the opening of a block e.g.  `data {`
    # We then regard all lines that follow as belonging to that block
    # until we see another block being opened e.g. `model{`
    results <- list()
    target <- NULL
    for (line in code) {
        for (block in names(stan_blocks)) {
            regex <- sprintf("^\\s*%s\\s*\\{\\s*$", stan_blocks[[block]])
            if (stringr::str_detect(line, regex)) {
                target <- block
                line <- NULL
                break
            }
        }
        if (!is.null(target)) {
            # This is memory inefficient but given the relatively small size of
            # stan files its regarded as a acceptable simplification to ease the
            # code burden
            results[[target]] <- c(results[[target]], line)
        }
    }

    # Loop over each block to remove trailing "}".
    for (block in names(results)) {
        block_length <- length(results[[block]])
        # The following processing is only required if the block actually has content
        if (block_length == 1 && results[[block]] == "") {
            next
        }
        has_removed_char <- FALSE
        # Walk backwards to find the closing `}` that corresponds to the `<block> {`
        for (index in rev(seq_len(block_length))) {
            line <- results[[block]][[index]]
            # This code will exit the for loop as soon as it hits the closing `}`
            # thus if we ever see a line that ends in text/numbers it means
            # somethings gone wrong
            if (stringr::str_detect(line, "[\\w\\d]+\\s*$")) {
                stop(sprintf(errmsg, block))
            }
            if (stringr::str_detect(line, "\\}\\s*$")) {
                new_line <- stringr::str_replace(line, "\\s*\\}\\s*$", "")
                # If the line is now blank after removing the closing `}` then drop the line
                keep_offset <- if (nchar(new_line) == 0) -1 else 0
                # Only keep lines from the start of the block to the closing `}`
                # this is to ensure we drop blank lines that were between the end
                # of the block and the start of the next
                keep_range <- seq_len(index + keep_offset)
                results[[block]][[index]] <- new_line
                results[[block]] <- results[[block]][keep_range]
                has_removed_char <- TRUE
                break
            }
        }
        # If we haven't actually removed a closing `}` then something has gone wrong...
        if (!has_removed_char) {
            stop(sprintf(errmsg, block))
        }
    }

    # Add any missing blocks back in
    for (block in names(stan_blocks)) {
        if (is.null(results[[block]])) {
            results[[block]] <- ""
        }
    }
    results
}

#' `StanModule` -> Printable `Character`
#'
#' Converts [`StanModule`] object into a printable string.
#' @typed object: StanModule
#'   A stan program
#' @family StanModule
#' @typed indent: numeric
#'   how much white space to prefix the print string with.
#' @keywords internal
#' @export
as_print_string.StanModule <- function(object, indent = 1, ...) {
    slots <- names(getSlots("StanModule"))
    components <- Filter(
        \(block) paste(slot(object, block), collapse = "") != "",
        slots
    )
    template <- c(
        "StanModule Object with components:",
        paste("    ", components)
    )
    pad <- rep(" ", indent) |> paste(collapse = "")
    template_padded <- paste(pad, template)
    sprintf(
        paste(template_padded, collapse = "\n")
    )
}

#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "StanModule",
    definition = function(object) {
        string <- as_print_string(object)
        cat("\n", string, "\n\n")
    }
)

#' @include SimLongitudinal.R
#' @include generics.R
NULL

#' Simulate Longitudinal Data from a Stein-Fojo Model
#'
#' @typed times: numeric
#'   the times to generate observations at.
#' @typed sigma: number
#'   the variance of the longitudinal values.
#' @typed mu_s: numeric
#'   the mean shrinkage rates for the two treatment arms.
#' @typed mu_g: numeric
#'   the mean growth rates for the two treatment arms.
#' @typed mu_b: numeric
#'   the mean baseline values for the two treatment arms.
#' @typed omega_b: number
#'   the baseline value standard deviation.
#' @typed omega_s: number
#'   the shrinkage rate standard deviation.
#' @typed omega_g: number
#'   the growth rate standard deviation.
#' @typed link_dsld: number
#'   the link coefficient for the derivative contribution.
#' @typed link_ttg: number
#'   the link coefficient for the time-to-growth contribution.
#' @typed link_identity: number
#'   the link coefficient for the SLD Identity contribution.
#' @typed link_growth: number
#'   the link coefficient for the log-growth parameter contribution.
#' @typed link_shrinkage: number
#'   the link coefficient for the log-shrinkage parameter contribution.
#' @typed scaled_variance: logical
#'   whether the variance should be scaled by the expected value
#'   (see the "Statistical Specifications" vignette for more details)
#'
#' @slot sigma (`numeric`)\cr See arguments.
#' @slot mu_s (`numeric`)\cr See arguments.
#' @slot mu_g (`numeric`)\cr See arguments.
#' @slot mu_b (`numeric`)\cr See arguments.
#' @slot omega_b (`numeric`)\cr See arguments.
#' @slot omega_s (`numeric`)\cr See arguments.
#' @slot omega_g (`numeric`)\cr See arguments.
#' @slot link_dsld (`numeric`)\cr See arguments.
#' @slot link_ttg (`numeric`)\cr See arguments.
#' @slot link_identity (`numeric`)\cr See arguments.
#' @slot link_growth (`numeric`)\cr See arguments.
#' @slot link_shrinkage (`numeric`)\cr See arguments.
#' @slot scaled_variance (`logical`)\cr See arguments.
#'
#' @family SimLongitudinal
#' @name SimLongitudinalSteinFojo-class
#' @exportClass SimLongitudinalSteinFojo
.SimLongitudinalSteinFojo <- setClass(
    "SimLongitudinalSteinFojo",
    contains = "SimLongitudinal",
    slots = c(
        sigma = "numeric",
        mu_s = "numeric",
        mu_g = "numeric",
        mu_b = "numeric",
        omega_b = "numeric",
        omega_s = "numeric",
        omega_g = "numeric",
        link_dsld = "numeric",
        link_ttg = "numeric",
        link_identity = "numeric",
        link_growth = "numeric",
        link_shrinkage = "numeric",
        scaled_variance = "logical"
    )
)

#' @rdname SimLongitudinalSteinFojo-class
#' @export
SimLongitudinalSteinFojo <- function(
    times = c(-100, -50, 0, 50, 100, 150, 250, 350, 450, 550) / 365,
    sigma = 0.01,
    mu_s = log(c(0.6, 0.4)),
    mu_g = log(c(0.25, 0.35)),
    mu_b = log(60),
    omega_b = 0.2,
    omega_s = 0.2,
    omega_g = 0.2,
    link_dsld = 0,
    link_ttg = 0,
    link_identity = 0,
    link_growth = 0,
    link_shrinkage = 0,
    scaled_variance = TRUE
) {
    if (length(omega_b) == 1) {
        omega_b <- rep(omega_b, length(mu_b))
    }
    if (length(omega_s) == 1) {
        omega_s <- rep(omega_s, length(mu_s))
    }
    if (length(omega_g) == 1) {
        omega_g <- rep(omega_g, length(mu_g))
    }

    .SimLongitudinalSteinFojo(
        times = times,
        sigma = sigma,
        mu_s = mu_s,
        mu_g = mu_g,
        mu_b = mu_b,
        omega_b = omega_b,
        omega_s = omega_s,
        omega_g = omega_g,
        link_dsld = link_dsld,
        link_ttg = link_ttg,
        link_identity = link_identity,
        link_growth = link_growth,
        link_shrinkage = link_shrinkage,
        scaled_variance = scaled_variance
    )
}


setValidity(
    "SimLongitudinalSteinFojo",
    function(object) {
        par_lengths <- c(
            length(object@mu_s),
            length(object@mu_g)
        )
        if (length(unique(par_lengths)) != 1) {
            return(
                "The parameters `mu_s` and `mu_g` must have the same length."
            )
        }
        pairs <- list(
            "omega_b" = "mu_b",
            "omega_s" = "mu_s",
            "omega_g" = "mu_g"
        )
        for (i in seq_along(pairs)) {
            omega <- slot(object, names(pairs)[[i]])
            mu <- slot(object, pairs[[i]])
            if (!(length(omega) == length(mu))) {
                return(
                    sprintf(
                        "`%s` must be length 1 or the same length as `%s`",
                        omega,
                        mu
                    )
                )
            }
        }
        len_1_pars <- c(
            "sigma",
            "link_dsld",
            "link_ttg",
            "link_identity",
            "link_growth",
            "link_shrinkage"
        )
        for (par in len_1_pars) {
            if (length(slot(object, par)) != 1) {
                return(sprintf(
                    "The `%s` parameter must be a length 1 numeric.",
                    par
                ))
            }
        }
        return(TRUE)
    }
)

#' @rdname as_print_string
#' @exportS3Method NULL
as_print_string.SimLongitudinalSteinFojo <- function(object, ...) {
    return("SimLongitudinalSteinFojo")
}

#' @rdname sampleObservations
#' @export
sampleObservations.SimLongitudinalSteinFojo <- function(object, times_df) {
    times_df |>
        dplyr::mutate(
            mu_sld = sf_sld(.data$time, .data$psi_b, .data$psi_s, .data$psi_g),
            dsld = sf_dsld(.data$time, .data$psi_b, .data$psi_s, .data$psi_g),
            ttg = sf_ttg(.data$time, .data$psi_b, .data$psi_s, .data$psi_g),
            sld_sd = ifelse(
                object@scaled_variance,
                .data$mu_sld * object@sigma,
                object@sigma
            ),
            sld = stats::rnorm(dplyr::n(), .data$mu_sld, .data$sld_sd),
            log_haz_link = (object@link_dsld * .data$dsld) +
                (object@link_ttg * .data$ttg) +
                (object@link_identity * .data$mu_sld) +
                (object@link_growth * log(.data$psi_g)) +
                (object@link_shrinkage * log(.data$psi_s))
        )
}


#' @rdname sampleSubjects
#' @export
sampleSubjects.SimLongitudinalSteinFojo <- function(object, subjects_df) {
    assert_that(
        is.factor(subjects_df$study),
        is.factor(subjects_df$arm),
        length(levels(subjects_df$study)) == length(object@mu_b),
        length(levels(subjects_df$arm)) == length(object@mu_s)
    )

    res <- subjects_df |>
        dplyr::distinct(.data$subject, .data$arm, .data$study) |>
        dplyr::mutate(
            study_idx = as.numeric(.data$study),
            arm_idx = as.numeric(.data$arm),
            psi_b = stats::rlnorm(
                dplyr::n(),
                object@mu_b[.data$study_idx],
                object@omega_b[.data$study_idx]
            ),
            psi_s = stats::rlnorm(
                dplyr::n(),
                object@mu_s[.data$arm_idx],
                object@omega_s[.data$arm_idx]
            ),
            psi_g = stats::rlnorm(
                dplyr::n(),
                object@mu_g[.data$arm_idx],
                object@omega_g[.data$arm_idx]
            )
        )

    res[, c("subject", "arm", "study", "psi_b", "psi_s", "psi_g")]
}


#' Stein-Fojo Functionals
#'
#' @typed time: numeric
#'   time grid.
#' @typed b: number
#'   baseline.
#' @typed s: number
#'   shrinkage.
#' @typed g: number
#'   growth.
#'
#' @returns The function results.
#' @keywords internal
sf_sld <- function(time, b, s, g) {
    s <- dplyr::if_else(time >= 0, s, 0)
    b * (exp(-s * time) + exp(g * time) - 1)
}


#' @rdname sf_sld
sf_ttg <- function(time, b, s, g) {
    t1 <- (log(s) - log(g)) / (g + s)
    t1[t1 <= 0] <- 0
    return(t1)
}


#' @rdname sf_sld
sf_dsld <- function(time, b, s, g) {
    s <- dplyr::if_else(time >= 0, s, 0)
    t1 <- g * exp(g * time)
    t2 <- s * exp(-s * time)
    return(b * (t1 - t2))
}

#' @include LongitudinalModel.R
#' @include StanModule.R
#' @include generics.R
#' @include ParameterList.R
#' @include Parameter.R
#' @include Link.R
NULL


#' `LongitudinalSteinFojo`
#'
#' This class extends the general [`LongitudinalModel`] class for using the
#' Stein-Fojo model for the longitudinal outcome.
#'
#' @section Available Links:
#' - [`linkDSLD()`]
#' - [`linkTTG()`]
#' - [`linkIdentity()`]
#' - [`linkGrowth()`]
#' @exportClass LongitudinalSteinFojo
.LongitudinalSteinFojo <- setClass(
    Class = "LongitudinalSteinFojo",
    contains = "LongitudinalModel"
)


#' @rdname LongitudinalSteinFojo-class
#'
#' @typed mu_bsld: Prior
#'   for the mean baseline value `mu_bsld`.
#' @typed mu_ks: Prior
#'   for the mean shrinkage rate `mu_ks`.
#' @typed mu_kg: Prior
#'   for the mean growth rate `mu_kg`.
#'
#' @typed omega_bsld: Prior
#'   for the baseline value standard deviation `omega_bsld`.
#' @typed omega_ks: Prior
#'   for the shrinkage rate standard deviation `omega_ks`.
#' @typed omega_kg: Prior
#'   for the growth rate standard deviation `omega_kg`.
#'
#' @typed sigma: Prior
#'   for the variance of the longitudinal values `sigma`.
#'
#' @typed scaled_variance: logical
#'   whether the variance should be scaled by the expected value
#'   (see the "Statistical Specifications" vignette for more details)
#' @typed centred: logical
#'   whether to use the centred parameterization.
#'
#' @export
LongitudinalSteinFojo <- function(
    mu_bsld = prior_normal(log(60), 1),
    mu_ks = prior_normal(log(0.5), 1),
    mu_kg = prior_normal(log(0.3), 1),

    omega_bsld = prior_lognormal(log(0.2), 1),
    omega_ks = prior_lognormal(log(0.2), 1),
    omega_kg = prior_lognormal(log(0.2), 1),

    sigma = prior_lognormal(log(0.1), 1),

    scaled_variance = TRUE,
    centred = FALSE
) {
    sf_model <- StanModule(decorated_render(
        .x = read_stan("lm-stein-fojo/model.stan"),
        centred = centred,
        scaled_variance = scaled_variance
    ))

    # Apply constriants
    omega_bsld <- set_limits(omega_bsld, lower = 0)
    omega_ks <- set_limits(omega_ks, lower = 0)
    omega_kg <- set_limits(omega_kg, lower = 0)
    sigma <- set_limits(sigma, lower = 0)

    parameters <- list(
        Parameter(name = "lm_sf_mu_bsld", prior = mu_bsld, size = "n_studies"),
        Parameter(name = "lm_sf_mu_ks", prior = mu_ks, size = "n_arms"),
        Parameter(name = "lm_sf_mu_kg", prior = mu_kg, size = "n_arms"),

        Parameter(
            name = "lm_sf_omega_bsld",
            prior = omega_bsld,
            size = "n_studies"
        ),
        Parameter(name = "lm_sf_omega_ks", prior = omega_ks, size = "n_arms"),
        Parameter(name = "lm_sf_omega_kg", prior = omega_kg, size = "n_arms"),

        Parameter(name = "lm_sf_sigma", prior = sigma, size = 1)
    )

    assert_flag(centred)
    parameters_extra <- if (centred) {
        list(
            Parameter(
                name = "lm_sf_psi_bsld",
                prior = prior_init_only(prior_lognormal(
                    median(mu_bsld),
                    median(omega_bsld)
                )),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_sf_psi_ks",
                prior = prior_init_only(prior_lognormal(
                    median(mu_ks),
                    median(omega_ks)
                )),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_sf_psi_kg",
                prior = prior_init_only(prior_lognormal(
                    median(mu_kg),
                    median(omega_kg)
                )),
                size = "n_subjects"
            )
        )
    } else {
        list(
            Parameter(
                name = "lm_sf_eta_tilde_bsld",
                prior = prior_std_normal(),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_sf_eta_tilde_ks",
                prior = prior_std_normal(),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_sf_eta_tilde_kg",
                prior = prior_std_normal(),
                size = "n_subjects"
            )
        )
    }
    parameters <- append(parameters, parameters_extra)

    x <- LongitudinalModel(
        name = "Stein-Fojo",
        stan = merge(
            sf_model,
            StanModule("lm-stein-fojo/functions.stan")
        ),
        parameters = do.call(ParameterList, parameters)
    )
    .LongitudinalSteinFojo(x)
}


#' @export
enableGQ.LongitudinalSteinFojo <- function(object, ...) {
    StanModule("lm-stein-fojo/quantities.stan")
}

#' @export
enableLink.LongitudinalSteinFojo <- function(object, ...) {
    object@stan <- merge(
        object@stan,
        StanModule("lm-stein-fojo/link.stan")
    )
    object
}

#' @export
linkDSLD.LongitudinalSteinFojo <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    LinkComponent(
        key = "link_dsld",
        stan = StanModule("lm-stein-fojo/link_dsld.stan"),
        prior = prior
    )
}

#' @export
linkTTG.LongitudinalSteinFojo <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    LinkComponent(
        key = "link_ttg",
        stan = StanModule("lm-stein-fojo/link_ttg.stan"),
        prior = prior
    )
}

#' @export
linkIdentity.LongitudinalSteinFojo <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    LinkComponent(
        key = "link_identity",
        stan = StanModule("lm-stein-fojo/link_identity.stan"),
        prior = prior
    )
}

#' @export
linkGrowth.LongitudinalSteinFojo <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    LinkComponent(
        key = "link_growth",
        stan = StanModule("lm-stein-fojo/link_growth.stan"),
        prior = prior
    )
}

#' @export
linkShrinkage.LongitudinalSteinFojo <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    LinkComponent(
        key = "link_shrinkage",
        stan = StanModule("lm-stein-fojo/link_shrinkage.stan"),
        prior = prior
    )
}

#' @rdname getPredictionNames
#' @export
getPredictionNames.LongitudinalSteinFojo <- function(object, ...) {
    c("b", "s", "g")
}


#' @rdname getRandomEffectsNames
#' @export
getRandomEffectsNames.LongitudinalSteinFojo <- function(object, ...) {
    c(
        "b" = "lm_sf_psi_bsld",
        "s" = "lm_sf_psi_ks",
        "g" = "lm_sf_psi_kg"
    )
}

#' Re-used documentation for `Quantities`
#'
#' @typed x: Quantities
#'   generated quantities.
#' @typed object: Quantities
#'   generated quantities.
#' @typed type: character
#'   sets the `type` variable.
#' @typed conf.level: numeric
#'   confidence level of the interval.
#' @param ... not used.
#'
#' @keywords internal
#' @name Quantities-Shared
NULL


#' Generated Quantities Container
#'
#' A simple wrapper around a `matrix` to store required metadata
#'
#' @typed quantities: matrix
#'   of generated quantities.
#' @typed times: numeric
#'   labels specifying which time point the quantity was generated at.
#' @typed groups: character
#'   labels for which group the quantity belongs to.
#'
#' @slot quantities (`matrix`)\cr See Arguments for details.
#' @slot times (`numeric`)\cr See Arguments for details.
#' @slot groups (`character`)\cr See Arguments for details.
#'
#' @details
#' Each row of the matrix represents a sample and each column represents a distinct quantity.
#' As such the number of columns in the matrix should equal the length of `times` and `groups`
#' which provide metadata for who the quantity belongs to and at what time point it was generated at.
#'
#' @keywords internal
#' @name Quantities-class
#' @family Quantities
.Quantities <- setClass(
    "Quantities",
    slots = list(
        "quantities" = "matrix",
        "times" = "numeric",
        "groups" = "character"
    )
)
#' @rdname Quantities-class
Quantities <- function(quantities, times, groups) {
    .Quantities(
        quantities = quantities,
        times = times,
        groups = groups
    )
}

setValidity(
    Class = "Quantities",
    method = function(object) {
        if (length(object@times) != length(object@groups)) {
            return("Length of `times` must be equal to the length of `groups`")
        }
        if (length(object@times) != ncol(object@quantities)) {
            return(
                "Length of `times` must be equal to the number of columns in `quantities`"
            )
        }
        return(TRUE)
    }
)


#' @export
dim.Quantities <- function(x) {
    dim(x@quantities)
}


#' `Quantities` -> `data.frame`
#'
#' @inheritParams Quantities-Shared
#'
#' @keywords internal
#' @family Quantities
#' @export
as.data.frame.Quantities <- function(x, ...) {
    data.frame(
        group = rep(x@groups, each = nrow(x@quantities)),
        time = rep(x@times, each = nrow(x@quantities)),
        values = as.vector(x@quantities)
    )
}


#' summary
#'
#' @description
#' This method returns a summary statistic `data.frame` of the quantities. Note that this
#' is just an internal utility method in order to share common code between
#' [LongitudinalQuantities] and [SurvivalQuantities]
#'
#' @inheritParams Quantities-Shared
#'
#' @returns
#' A `data.frame` with the following variables:
#' - `median` (`numeric`) \cr the median value of the quantity.
#' - `lower` (`numeric`) \cr the lower CI value of the quantity.
#' - `upper` (`numeric`) \cr the upper CI value of the quantity.
#' - `time` (`numeric`) \cr the time point which the quantity is for.
#' - `group` (`character`) \cr which group the quantity belongs to.
#' - `type` (`character`) \cr what type of quantity is it.
#'
#' @keywords internal
#' @family Quantities
#' @export
summary.Quantities <- function(object, conf.level = 0.95, ...) {
    quantities_summarised <- samples_median_ci(
        object@quantities,
        level = conf.level
    )

    quantities_summarised$group <- object@groups
    quantities_summarised$time <- object@times
    quantities_summarised[, c("group", "time", "median", "lower", "upper")]
}


#' Create Grouped Quantities
#'
#' This function takes a matrix of quantity samples and aggregates them by calculating the
#' pointwise average.
#'
#' @typed quantities_raw: matrix
#'   of samples with 1 row per sample and 1 column per
#'   distinct quantity.
#'
#' @typed collapser: QuantityCollapser
#'   specifies which columns to combine together.
#'
#' @details
#' This function essentially implements the group wise average by collapsing multiple columns
#' together based on the specification provided by the `QuantityCollapser` object.
#' The [Grid-Dev] page provides an example of what this function implements
#'
#' @keywords internal
collapse_quantities <- function(quantities_raw, collapser) {
    assert_class(quantities_raw, "matrix")
    assert_class(collapser, "QuantityCollapser")

    quantities <- matrix(
        NA,
        nrow = nrow(quantities_raw),
        ncol = length(collapser)
    )

    for (idx in seq_along(collapser)) {
        quantities[, idx] <- quantities_raw[,
            collapser@indexes[[idx]],
            drop = FALSE
        ] |>
            rowMeans()
    }

    return(quantities)
}

#' Extract Survival Quantities
#'
#' Utility function to extract generated quantities from a [cmdstanr::CmdStanGQ] object.
#' Multiple quantities are generated by default so this is a convenience function to extract
#' the desired ones and return them them as a user friendly [posterior::draws_matrix] object
#'
#' @typed gq: CmdStanGQ
#'   a [cmdstanr::CmdStanGQ] object created by [generateQuantities()].
#' @typed type: character
#'   quantity to be generated.
#'   Must be one of `surv`, `haz`, `loghaz`, `cumhaz`, `lm_identity`.
#' @keywords internal
extract_quantities <- function(
    gq,
    type = c("surv", "haz", "loghaz", "cumhaz", "lm_identity")
) {
    type <- match.arg(type)
    assert_class(gq, "CmdStanGQ")
    meta <- switch(
        type,
        surv = list("log_surv_fit_at_time_grid", exp),
        cumhaz = list("log_surv_fit_at_time_grid", \(x) -x),
        haz = list("log_haz_fit_at_time_grid", exp),
        loghaz = list("log_haz_fit_at_time_grid", identity),
        lm_identity = list("y_fit_at_time_grid", identity)
    )
    result <- gq$draws(meta[[1]], format = "draws_matrix")
    result_transformed <- meta[[2]](result)
    cnames <- colnames(result_transformed)
    colnames(result_transformed) <- gsub(meta[[1]], "quantity", cnames)
    result_transformed
}


#' `Quantities` -> Printable `Character`
#'
#' Converts [`Quantities`] object into a printable string.
#' @inheritParams Quantities-Shared
#' @family Quantities
#' @keywords internal
#' @export
as_print_string.Quantities <- function(object, indent = 1, ...) {
    template <- c(
        "Quantities Object:",
        "    # of samples    = %d",
        "    # of quantities = %d"
    )
    pad <- rep(" ", indent) |> paste(collapse = "")
    template_padded <- paste(pad, template)
    sprintf(
        paste(template_padded, collapse = "\n"),
        nrow(object),
        ncol(object)
    )
}


#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "Quantities",
    definition = function(object) {
        string <- as_print_string(object)
        cat("\n", string, "\n\n")
    }
)

#' Simulating Joint Longitudinal and Time-to-Event Data
#'
#' @typed design: list
#'   a list of [`SimGroup`] objects. See details.
#' @typed longitudinal: SimLongitudinal
#'   object specifying how to simulate the longitudinal data
#' @typed survival: SimSurvival
#'   object specifying how to simulate the survival data
#' @typed .silent: flag
#'   whether to suppress info messages
#'
#' @slot longitudinal (`data.frame`)\cr the simulated longitudinal data.
#' @slot survival (`data.frame`)\cr the simulated survival data.
#'
#' @details
#'
#' The `design` argument is used to specify how many distinct groups should be simulated
#' including key information such as the number of subjects within the group as well as
#' which treatment arm and study the group belongs to. The `design` argument should be a
#' list of [`SimGroup`] objects e.g.
#' ```
#' design = list(
#'     SimGroup(n = 50, study = "Study-1", arm = "Arm-A"),
#'     SimGroup(n = 50, study = "Study-1", arm = "Arm-B")
#'   )
#' ```
#'
#' @name SimJointData-class
#' @exportClass SimJointData
.SimJointData <- setClass(
    "SimJointData",
    slots = list(
        longitudinal = "data.frame",
        survival = "data.frame"
    )
)


#' @rdname SimJointData-class
#' @export
SimJointData <- function(
    design = list(
        SimGroup(n = 50, study = "Study-1", arm = "Arm-A"),
        SimGroup(n = 50, study = "Study-1", arm = "Arm-B")
    ),
    longitudinal,
    survival,
    .silent = FALSE
) {
    assert(
        all(vapply(design, \(x) is(x, "SimGroup"), logical(1))),
        msg = "All elements of `design` must be of class `SimGroup`"
    )

    hazard_evaluation_info <- hazardWindows(survival)

    n_group <- vapply(design, function(x) x@n, numeric(1))
    arms <- vapply(design, function(x) x@arm, character(1))
    studies <- vapply(design, function(x) x@study, character(1))
    n_subjects <- sum(n_group)
    n_times <- length(hazard_evaluation_info$midpoint)

    sprintf_string <- paste0(
        "subject_%0",
        ceiling(log(n_subjects, 10)) + 1,
        "i"
    )

    baseline <- dplyr::tibble(
        subject = sprintf(sprintf_string, seq_len(n_subjects))
    ) |>
        dplyr::mutate(
            arm = factor(rep(arms, times = n_group), levels = unique(arms))
        ) |>
        dplyr::mutate(
            study = factor(
                rep(studies, times = n_group),
                levels = unique(studies)
            )
        )

    os_baseline <- sampleSubjects(survival, subjects_df = baseline)
    lm_baseline <- sampleSubjects(longitudinal, subjects_df = baseline)

    lm_dat_no_obvs <- lapply(
        longitudinal@times,
        \(time) {
            baseline[["time"]] <- time
            baseline
        }
    ) |>
        dplyr::bind_rows() |>
        dplyr::left_join(lm_baseline, by = c("subject", "study", "arm"))

    lm_dat <- sampleObservations(longitudinal, lm_dat_no_obvs)

    hazard_eval_df <- dplyr::tibble(
        subject = rep(lm_baseline$subject, each = n_times),
        arm = rep(lm_baseline$arm, each = n_times),
        study = rep(lm_baseline$study, each = n_times),
        midpoint = rep(
            as.double(hazard_evaluation_info$midpoint),
            times = n_subjects
        ),
        time = rep(as.double(hazard_evaluation_info$upper), times = n_subjects),
        width = rep(as.double(hazard_evaluation_info$width), times = n_subjects)
    )

    lm_link_dat <- sampleObservations(
        longitudinal,
        dplyr::left_join(
            hazard_eval_df,
            lm_baseline,
            by = c("subject", "study", "arm")
        )
    )[, c(
        "subject",
        "study",
        "arm",
        "log_haz_link",
        "time",
        "width",
        "midpoint"
    )]

    os_eval_df <- lm_link_dat |>
        dplyr::left_join(os_baseline, by = c("subject", "study", "arm"))

    withCallingHandlers(
        os_dat <- sampleObservations(survival, os_eval_df),
        message = function(e) {
            if (!.silent) {
                message(e)
            }
            invokeRestart("muffleMessage")
        }
    )

    lm_dat2 <- lm_dat |>
        dplyr::left_join(
            dplyr::select(os_dat, "subject", os_time = "time"),
            by = "subject"
        ) |>
        dplyr::mutate(observed = (.data$time <= .data$os_time)) |>
        dplyr::arrange(dplyr::pick(c("subject", "time")))

    assert_that(
        length(unique(os_dat$subject)) == length(os_dat$subject),
        length(os_dat$subject) == n_subjects,
        all(os_dat$time >= 0),
        all(os_dat$event %in% c(0, 1)),
        msg = "Assumptions for the Survival data are not met (please report this issue)"
    )

    assert_that(
        nrow(lm_dat2) == n_subjects * length(longitudinal@times),
        length(unique(lm_dat2$subject)) == n_subjects,
        msg = "Assumptions for the Longitudinal data are not met (please report this issue)"
    )

    return(
        .SimJointData(
            survival = os_dat,
            longitudinal = lm_dat2[, c(
                "subject",
                "arm",
                "study",
                "time",
                "sld",
                "observed"
            )]
        )
    )
}

#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "SimJointData",
    definition = function(object) {
        x <- sprintf("\nA SimJointData Object\n\n")
        cat(x)
        return(object)
    }
)


#' Add PFS events at Tumour Progression to Data
#'
#' Adds new columns `pfs_time` and `pfs_event` based on observed changes to SLD.
#'
#' @param object A [SimJointData] object
#' @typed relative_threshold: number
#'   a multiplicative threshold for the change in SLD compared to the `min(SLD)`.
#'   Default is 1.2 meaning a 20% increase.
#' @typed absolute_threshold: number
#'   an absolute threshold for the change in SLD compared to the minimum.
#'   Default is 5.
#' @typed from_time: number
#'   Ignore observations before this time for determining SLD minimum.
#' @typed observed_after: logical
#'   If `FALSE` set longitudinal observations after the progression time to
#'   `observed = FALSE`
#' @details
#' Both thresholds must be met for a progression to be declared.
#'
#' @export
#' @examples
#' data <- SimJointData(
#'   survival = SimSurvivalExponential(lambda = 1/10),
#'   longitudinal = SimLongitudinalSteinFojo()
#'   )
#' data <- add_pfs(data)
#' data@survival # now has pfs_time and pfs_event columns
add_pfs <- function(
    object,
    relative_threshold = 1.2,
    absolute_threshold = 5,
    from_time = 0,
    observed_after = FALSE
) {
    assert_class(object, "SimJointData")

    pd_times <- object@longitudinal |>
        dplyr::filter(.data$time >= from_time) |>
        dplyr::mutate(
            min_sld = cummin(.data$sld),
            is_pd = .data$sld >=
                pmax(
                    .data$min_sld * relative_threshold,
                    .data$min_sld + absolute_threshold
                ) &
                .data$observed,
            pd_time = min(.data$time[.data$is_pd], Inf),
            .by = "subject"
        ) |>
        dplyr::select("subject", "pd_time") |>
        dplyr::slice_head(by = "subject")

    if (isFALSE(observed_after)) {
        object@longitudinal <- object@longitudinal |>
            dplyr::left_join(pd_times, by = "subject") |>
            dplyr::mutate(
                observed = dplyr::if_else(
                    .data$time > .data$pd_time,
                    FALSE,
                    .data$observed
                ),
                pd_time = NULL
            )
    }

    object@survival <-
        object@survival |>
        dplyr::left_join(pd_times, by = "subject") |>
        dplyr::mutate(
            pfs_time = pmin(.data$time, .data$pd_time, na.rm = TRUE),
            pfs_event = dplyr::if_else(
                .data$pfs_time < .data$time,
                1,
                .data$event
            ),
            pd_time = NULL
        )
    object
}


#' Cut Study Data
#' @param object A [SimJointData] object
#' @typed cut_time: numeric
#'   A vector of cut off times, either length 1 for all patients or
#'   `nrow(object@survival)` for a time per patient.
#' @details
#'   All observations after this time are remove. Survival is censored at this time and any longitudinal
#'   values are removed.
#' @export
#' @examples
#' data <- SimJointData(
#'   survival = SimSurvivalExponential(lambda = 1/10),
#'   longitudinal = SimLongitudinalSteinFojo()
#'   )
#' data <- cut_data(data, 5)
#' data@survival
#' # Now max time is 5
#' max(data@survival$time)
cut_data <- function(object, cut_time) {
    assert_class(object, "SimJointData")
    check_len <- if (length(cut_time) > 1) nrow(object@survival) else 1
    assert_numeric(cut_time, lower = 0, len = check_len)

    object@survival <- object@survival |>
        dplyr::mutate(
            cut_time = cut_time,
            event = dplyr::if_else(.data$time < .data$cut_time, .data$event, 0),
            time = pmin(.data$cut_time, .data$time)
        )
    if (all(c("pfs_event", "pfs_time") %in% colnames(object@survival))) {
        object@survival <- object@survival |>
            dplyr::mutate(
                pfs_event = dplyr::if_else(
                    .data$pfs_time < .data$cut_time,
                    .data$pfs_event,
                    0
                ),
                pfs_time = pmin(.data$cut_time, .data$pfs_time)
            )
    }

    object@longitudinal <- object@longitudinal |>
        dplyr::left_join(
            dplyr::select(object@survival, "subject", "cut_time"),
            by = "subject"
        ) |>
        dplyr::filter(.data$time <= .data$cut_time) |>
        dplyr::mutate(cut_time = NULL)

    object@survival$cut_time <- NULL

    object
}

#' @include DataJoint.R
#' @include Quantities.R
NULL


#' Re-used documentation for `SurvivalQuantities`
#'
#' @typed object: SurvivalQuantities
#'   survival quantities.
#' @typed x: SurvivalQuantities
#'   survival quantities.
#' @param ... not used.
#'
#' @keywords internal
#' @name SurvivalQuantities-Shared
NULL


#' `SurvivalQuantities` Object & Constructor Function
#'
#' Constructor function to generate a `SurvivalQuantities` object.
#'
#' @slot quantities (`Quantities`)\cr The sampled quantities. Should contain 1 element per
#' element of `group`
#' @slot groups (`list`)\cr See argument section for details
#' @slot type (`character`)\cr See See argument section for details
#' @slot time_grid (`numeric`)\cr See argument section for details
#' @slot data ([`DataJoint`])\cr The data that the Joint Model was fitted to to produce
#' the samples/quantities
#'
#' @section Group Specification:
#' If `groups` is a character vector of subject IDs then the survival quantities will
#' only be calculated for those specific subjects.
#'
#' If `groups` is a list then any elements with more than 1 subject ID will be grouped together
#' and their quantities will be calculated by taking a point-wise average.
#' For example: `groups = list("g1" = c("sub1", "sub2"), "g2" = c("sub3", "sub4"))` would result
#' in 2 groups being created whose values are the pointwise average
#' of `c("sub1", "sub2")` and `c("sub3", "sub4")` respectively.
#'
#' If `groups=NULL` then all subjects from original dataset will be selected
#'
#' @family SurvivalQuantities
#' @name SurvivalQuantities-class
#' @export SurvivalQuantities
.SurvivalQuantities <- setClass(
    Class = "SurvivalQuantities",
    slots = c(
        "quantities" = "Quantities",
        "grid" = "Grid",
        "type" = "character",
        "data" = "DataJoint"
    )
)

#' @typed object: JointModelSamples
#'   samples as drawn from a Joint Model.
#'
#' @typed grid: Grid
#'   object that specifies which subjects and time points to calculate the
#'   quantities for. See [Grid-Functions].
#'
#' @typed type: character
#'   quantity to be generated.
#'   Must be one of `surv`, `haz`, `loghaz`, `cumhaz`.
#'
#' @rdname SurvivalQuantities-class
SurvivalQuantities <- function(
    object,
    grid,
    type = c("surv", "haz", "loghaz", "cumhaz")
) {
    type <- match.arg(type)
    assert_class(object, "JointModelSamples")
    assert_class(grid, "Grid")
    assert_that(
        !is(grid, "GridPopulation"),
        msg = "GridPopulation objects are not supported for `SurvivalQuantities`"
    )

    time_grid <- seq(
        from = 0,
        to = max(as.list(object@data)[["event_times"]]),
        length = 201
    )

    grid <- coalesceGridTime(grid, time_grid)

    generator <- as.QuantityGenerator(grid, data = object@data)

    assert_that(
        all(generator@times >= 0),
        msg = "Time points must be greater than or equal to 0"
    )

    gq <- generateQuantities(
        object,
        generator = generator,
        type = "survival"
    )

    quantities_raw <- extract_quantities(gq, type)
    collapser <- as.QuantityCollapser(grid, object@data)
    quantities <- collapse_quantities(quantities_raw, collapser)

    .SurvivalQuantities(
        quantities = Quantities(
            quantities,
            groups = collapser@groups,
            times = collapser@times
        ),
        grid = grid,
        data = object@data,
        type = type
    )
}


#' `as.data.frame`
#'
#' @typed x: SurvivalQuantities
#'   longitudinal quantities.
#' @param ... not used.
#' @family SurvivalQuantities
#' @export
as.data.frame.SurvivalQuantities <- function(x, ...) {
    as.data.frame(x@quantities)
}


#' summary
#'
#' @description
#' This method returns a `data.frame` of the longitudinal quantities.
#'
#' @typed conf.level: numeric
#'   confidence level of the interval.
#' @inheritParams SurvivalQuantities-Shared
#'
#' @family SurvivalQuantities
#' @family summary
#' @export
summary.SurvivalQuantities <- function(
    object,
    conf.level = 0.95,
    ...
) {
    summary(object@quantities, conf.level = conf.level)
}


#' Automatic Plotting for `SurvivalQuantities``
#'
#' @inheritParams SurvivalQuantities-Shared
#' @typed add_km: logical
#'   if `TRUE` Kaplan-Meier curves will be added to the plot for
#'   each group/subject.
#' @typed add_wrap: logical
#'   if `TRUE` will apply a [ggplot2::facet_wrap()] to the plot
#'   by each group/subject.
#' @typed conf.level: numeric
#'   confidence level of the interval. If values of `FALSE`,
#'   `NULL` or `0` are provided then confidence regions will not be added to the plot
#' @param ... not used.
#'
#' @family SurvivalQuantities
#' @family autoplot
#' @export
autoplot.SurvivalQuantities <- function(
    object,
    conf.level = 0.95,
    add_km = FALSE,
    add_wrap = TRUE,
    ...
) {
    include_ci <- !is.null(conf.level) &&
        is.numeric(conf.level) &&
        conf.level > 0
    # If CI aren't needed supply a default 0.95 to summary function as it needs
    # a value to be specified to work
    conf.level <- if (include_ci) conf.level else 0.95
    assert_that(
        is.flag(add_km),
        length(conf.level) == 1,
        conf.level < 1,
        is.flag(add_wrap)
    )
    kmdf <- if (add_km) {
        subset(
            object@data,
            as.list(object@grid, data = object@data)
        )
    } else {
        NULL
    }
    all_fit_df <- summary(object, conf.level = conf.level)
    label <- switch(
        object@type,
        "surv" = expression(S(t)),
        "cumhaz" = expression(H(t)),
        "haz" = expression(h(t)),
        "loghaz" = expression(log(h(t)))
    )
    survival_plot(
        data = all_fit_df,
        add_ci = include_ci,
        add_wrap = add_wrap,
        kmdf = kmdf,
        y_label = label
    )
}


#' Survival Plot
#'
#' Internal plotting function to create survival plots with KM curve overlays
#' This function predominately exists to extract core logic into its own function
#' to enable easier unit testing.
#'
#' @typed data: data.frame
#'   summary statistics for a survival
#'   curve to be plotted. See details.
#' @typed add_ci: logical
#'   should confidence intervals be added? Default = `TRUE`.
#' @typed add_wrap: logical
#'   should the plots be wrapped by `data$group`? Default = `TRUE`.
#' @typed kmdf: "`data.frame` or `NULL`"
#'   event times and status used to plot
#'   overlaying KM curves. If `NULL` no KM curve will be plotted. See details.
#' @typed y_label: "`character` or `expression`"
#'   label to display on the y-axis.
#'   Default = `expression(S(t))`.
#' @typed x_label: "`character` or `expression`"
#'   label to display on the x-axis.
#'
#' @details
#'
#' ## `data`
#' Should contain the following columns:
#' - `time` (`numeric`) \cr time point for the summary statistic.
#' - `group` (`character`) \cr the group in which the observation belongs to.
#' - `median` (`numeric`) \cr the median value for the summary statistic.
#' - `upper` (`numeric`) \cr the upper 95% CI for the summary statistic.
#' - `lower` (`numeric`) \cr the lower 95% CI for the summary statistic.
#'
#' ## `kmdf`
#' Should contain the following columns:
#' - `time` (`numeric`) \cr the time at which an event occurred.
#' - `event` (`numeric`) \cr 1/0 status indicator for the event.
#' - `group` (`character`) \cr which group the event belongs to, should correspond to values in `data$group`.
#' @keywords internal
survival_plot <- function(
    data,
    add_ci = TRUE,
    add_wrap = TRUE,
    kmdf = NULL,
    y_label = expression(S(t)),
    x_label = expression(t)
) {
    assert_that(
        is.flag(add_ci),
        is.flag(add_wrap),
        is.expression(y_label) || is.character(y_label),
        is.expression(x_label) || is.character(x_label),
        is.null(kmdf) | is.data.frame(kmdf)
    )

    p <- ggplot() +
        xlab(x_label) +
        ylab(y_label) +
        theme_bw()

    if (add_wrap) {
        p <- p + facet_wrap(~group)
        aes_ci <- aes(x = .data$time, ymin = .data$lower, ymax = .data$upper)
        aes_line <- aes(x = .data$time, y = .data$median)
        aes_km <- aes(time = .data$time, status = .data$event)
    } else {
        aes_ci <- aes(
            x = .data$time,
            ymin = .data$lower,
            ymax = .data$upper,
            fill = .data$group,
            group = .data$group
        )
        aes_line <- aes(
            x = .data$time,
            y = .data$median,
            colour = .data$group,
            group = .data$group
        )
        aes_km <- aes(
            time = .data$time,
            status = .data$event,
            group = .data$group,
            colour = .data$group
        )
    }
    p <- p + geom_line(aes_line, data = data)
    if (add_ci) {
        p <- p + geom_ribbon(aes_ci, data = data, alpha = 0.3)
    }
    if (!is.null(kmdf)) {
        p <- p +
            ggplot2.utils::geom_km(aes_km, data = kmdf) +
            ggplot2.utils::geom_km_ticks(aes_km, data = kmdf)
    }
    p
}


#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "SurvivalQuantities",
    definition = function(object) {
        template <- c(
            "SurvivalQuantities Object:",
            "    # of samples    = %d",
            "    # of quantities = %d",
            "    Type            = %s"
        )
        string <- sprintf(
            paste(template, collapse = "\n"),
            nrow(object@quantities),
            ncol(object@quantities),
            object@type
        )
        cat("\n", string, "\n\n")
    }
)


#' `brierScore`
#'
#' @description
#' Derives the Brier Scores (using Inverse Probability of Censoring Weighting)
#' for the Survival estimates as detailed in \insertCite{blanche2015}{jmpost}.
#'
#' @inheritParams SurvivalQuantities-Shared
#' @inheritParams Brier-Score-Shared
#'
#' @family brierScore
#' @family SurvivalQuantities
#' @references
#' \insertAllCited{}
#' @export
brierScore.SurvivalQuantities <- function(
    object,
    maintain_cen_order = TRUE,
    event_offset = TRUE,
    ...
) {
    assert_that(
        object@type == "surv",
        msg = paste(
            "Brier Score can only be calculated when the survival quantities were",
            "generated with `type = 'surv'`",
            collapse = " "
        )
    )
    assert_that(
        is(object@grid, "GridFixed"),
        msg = paste(
            "Brier Score can only be calculated when the survival quantities were",
            "generated with `grid = GridFixed()`",
            collapse = " "
        )
    )

    sdat <- summary(object)
    times <- unique(as.QuantityGenerator(object@grid, object@data)@times)
    times <- times[order(times)]
    assert_that(
        nrow(sdat) == length(times) * length(unique(sdat$group))
    )

    subject_col <- extractVariableNames(object@data@subject)$subject
    time_col <- extractVariableNames(object@data@survival)$time
    event_col <- extractVariableNames(object@data@survival)$event
    groups <- as.character(object@data@survival@data[[subject_col]])
    orig_times <- object@data@survival@data[[time_col]]
    events <- as.numeric(object@data@survival@data[[event_col]])

    pred_mat <- matrix(
        ncol = length(times),
        nrow = length(unique(sdat$group))
    )
    for (i in seq_along(times)) {
        pred_mat[, i] <- sdat[sdat["time"] == times[i], "median"]
        assert_that(
            all(groups == sdat[sdat["time"] == times[i], "group"])
        )
    }
    brier_score(
        t = times,
        times = orig_times,
        events = events,
        pred_mat = 1 - pred_mat,
        maintain_cen_order = maintain_cen_order,
        event_offset = event_offset
    )
}

#' @include DataSurvival.R
#' @include DataLongitudinal.R
#' @include DataSubject.R
NULL


#' Re-used documentation for `DataJoint`
#'
#' @typed object: DataJoint
#'   Survival and Longitudinal Data.
#' @typed x: DataJoint
#'   Survival and Longitudinal Data.
#' @param ... Not Used.
#'
#' @name DataJoint-Shared
#' @keywords internal
NULL

setClassUnion("DataLongitudinal_or_NULL", c("DataLongitudinal", "NULL"))
setClassUnion("DataSurvival_or_NULL", c("DataSurvival", "NULL"))


# DataJoint-class ----

#' @title
#' Joint Data Object and Constructor Function
#'
#' @description
#' The `DataJoint` class handles combining data from a [`DataSurvival`] object and a
#' [`DataLongitudinal`] object.
#'
#' @slot subject (`DataSubject`)\cr See Argument for details.
#' @slot survival (`DataSurvival`)\cr See Argument for details.
#' @slot longitudinal (`DataLongitudinal`)\cr See Argument for details.
#'
#' @family DataObjects
#' @family DataJoint
#' @export DataJoint
#' @exportClass DataJoint
.DataJoint <- setClass(
    Class = "DataJoint",
    representation = list(
        subject = "DataSubject",
        survival = "DataSurvival_or_NULL",
        longitudinal = "DataLongitudinal_or_NULL"
    )
)

#' @typed subject: DataSubject
#'   object created by [DataSubject()].
#' @typed survival: DataSurvival
#'   object created by [DataSurvival()].
#' @typed longitudinal: DataLongitudinal
#'   object created by [DataLongitudinal()].
#' @rdname DataJoint-class
DataJoint <- function(subject, survival = NULL, longitudinal = NULL) {
    subject_suited <- harmonise(subject)
    vars <- extractVariableNames(subject)
    subject_var <- vars$subject
    subject_ord <- levels(as.data.frame(subject_suited)[[vars$subject]])

    survival_suited <- harmonise(
        survival,
        subject_var = subject_var,
        subject_ord = subject_ord
    )

    longitudinal_suited <- harmonise(
        longitudinal,
        subject_var = subject_var,
        subject_ord = subject_ord
    )

    .DataJoint(
        subject = subject_suited,
        survival = survival_suited,
        longitudinal = longitudinal_suited
    )
}


setValidity(
    Class = "DataJoint",
    method = function(object) {
        vars <- extractVariableNames(object@subject)
        subject_var <- vars$subject
        subject_ord <- as.character(as.data.frame(object@subject)[[
            vars$subject
        ]])
        if (!is.null(object@survival)) {
            survival_df <- as.data.frame(object@survival)
            if (!subject_var %in% names(survival_df)) {
                return(sprintf(
                    "Unable to find `%s` in `survival`",
                    sujbect_var
                ))
            }
            if (!all(survival_df[[subject_var]] %in% subject_ord)) {
                return(
                    "There are subjects in `survival` that are not in `subject`"
                )
            }
            if (
                !nrow(survival_df) == length(unique(survival_df[[subject_var]]))
            ) {
                return("There are duplicate subjects in `survival`")
            }
        }
        if (!is.null(object@longitudinal)) {
            long_df <- as.data.frame(object@longitudinal)
            if (!subject_var %in% names(long_df)) {
                return(sprintf(
                    "Unable to find `%s` in `longitudinal`",
                    sujbect_var
                ))
            }
            if (!all(long_df[[subject_var]] %in% subject_ord)) {
                return(
                    "There are subjects in `longitudinal` that are not in `subject`"
                )
            }
        }
        subject_df <- as.data.frame(object@subject)
        if (!subject_var %in% names(subject_df)) {
            return(sprintf("Unable to find `%s` in `subject`", sujbect_var))
        }
        if (!nrow(subject_df) == length(unique(subject_df[[subject_var]]))) {
            return("There are duplicate subjects in `subject`")
        }
        return(TRUE)
    }
)


# DataJoint-as.list ----

#' Data Object -> `list`
#'
#' @typed object: "`DataSubject` or `DataLongitudinal` or `DataSurvival`"
#'   data object to convert to a `list`.
#' @typed x: "`DataSubject` or `DataLongitudinal` or `DataSurvival`"
#'   data object to convert to a `list`.
#' @typed subject_var: character
#'   the name of the variable
#'   containing the subject identifier.
#' @param ... not used.
#'
#' @description
#' Coerces a data object into a `list` of data components required
#' for fitting a [`JointModel`]. See the "Extending jmpost" vignette for more details.
#'
#' @name as_stan_list.DataObject
#' @family as_stan_list
#' @family DataJoint
#' @export
as_stan_list.DataJoint <- function(object, ...) {
    vars <- extractVariableNames(object@subject)
    subject_var <- vars$subject
    as_stan_list(object@subject) |>
        append(as_stan_list(object@survival)) |>
        append(as_stan_list(
            object@longitudinal,
            subject_var = subject_var
        ))
}

#' @rdname as_stan_list.DataObject
#' @export
as.list.DataJoint <- function(x, ...) {
    as_stan_list(x, ...)
}


#' Subsetting `DataJoint` as a `data.frame`
#'
#' @typed x: DataJoint
#'   object created by [DataJoint()].
#' @typed subjects: "`character` or `list`"
#'   subjects that you wish to subset the `data.frame`
#'   to contain. See details.
#' @param ... Not used.
#'
#' @description
#'
#' Coerces the object into a `data.frame` containing just event times and status
#' filtering for specific subjects If `subjects` is a list then an additional variable `group` will be added
#' onto the dataset specifying which group the row belongs to.
#'
#' @examples
#' \dontrun{
#' subjects <- c("SUB1", "SUB2", "SUB3", "SUB4")
#' subset(x, subjects)
#'
#' groups <- list(
#'     "g1" = c("SUB1", "SUB3", "SUB4"),
#'     "g2" = c("SUB2", "SUB3")
#'   )
#' subset(x, groups)
#' }
#' @family DataJoint
#' @export
subset.DataJoint <- function(x, subjects, ...) {
    data <- as.list(x)
    dat <- data.frame(
        time = data[["event_times"]],
        event = as.numeric(
            seq_along(data[["event_times"]]) %in% data[["subject_event_index"]]
        ),
        subject = names(data[["subject_to_index"]])
    )
    subset_and_add_grouping(dat, subjects)
}


#' `subset_and_add_grouping`
#'
#' @typed dat: data.frame
#'   must have a column called `subject` which corresponds to the
#'   values passed to `groupings`.
#' @typed groupings: "`character` or `list`"
#'   subjects that you wish to subset the dataset
#'   to contain. If `groupings` is a list then an additional variable `group` will be added
#' onto the dataset specifying which group the row belongs to.
#'
#' @details
#' Example of usage
#' ```
#' subjects <- c("SUB1", "SUB2", "SUB3", "SUB4")
#' subset_and_add_grouping(dat, subjects)
#'
#' groups <- list(
#'     "g1" = c("SUB1", "SUB3", "SUB4"),
#'     "g2" = c("SUB2", "SUB3")
#'   )
#' subset_and_add_grouping(dat, groups)
#' ```
#'
#' @keywords internal
subset_and_add_grouping <- function(dat, groupings) {
    groupings <- decompose_subjects(groupings, dat$subject)$groups
    dat_subset_list <- lapply(
        seq_along(groupings),
        \(i) {
            dat_reduced <- dat[dat$subject %in% groupings[[i]], , drop = FALSE]
            dat_reduced[["group"]] <- names(groupings)[[i]]
            dat_reduced
        }
    )
    x <- Reduce(rbind, dat_subset_list)
    row.names(x) <- NULL
    x
}


#' Extract Observed Longitudinal Values
#'
#' Utility function to extract the observed longitudinal values from a [`DataJoint`] object
#' @typed object: DataJoint
#'   data used to fit a [`JointModel`].
#' @return A data.frame with the following columns
#' - `subject` (`character`)\cr The subject identifier
#' - `time` (`numeric`)\cr The time at which the observation occurred
#' - `Yob` (`numeric`)\cr The observed value
#' @keywords internal
extract_observed_values <- function(object) {
    assert_class(object, "DataJoint")
    data <- as.list(object)
    x <- data.frame(
        subject = names(data$subject_to_index)[data$subject_tumour_index],
        time = data$tumour_time,
        Yob = data$tumour_value
    )
    row.names(x) <- NULL
    x
}

#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "DataJoint",
    definition = function(object) {
        string_survival <- if (is.null(object@survival)) {
            "      Survival-Data Object:\n          Not Specified"
        } else {
            as_print_string(object@survival, indent = 5)
        }

        string_longitudinal <- if (is.null(object@longitudinal)) {
            "      Longitudinal-Data Object:\n          Not Specified"
        } else {
            as_print_string(object@longitudinal, indent = 5)
        }

        template <- c(
            "Joint-Data Object Containing:",
            "",
            as_print_string(object@subject, indent = 5),
            "",
            string_survival,
            "",
            string_longitudinal
        )
        cat("\n", paste(template, collapse = "\n"), "\n\n")
    }
)

#' Row Numbers of Data with Missing Variables
#'
#' @typed df: data.frame
#'   input data.
#' @typed formula: "`formula` or `NULL`"
#'   which variables to inspect for missingness, if `NULL`
#'   all variables are considered.
#'
#' @returns Numeric vector specifying which rows contain at least 1 missing observation
#'   in any of the inspected variables.
#'
#' @keywords internal
get_missing_rownumbers <- function(df, formula = NULL) {
    if (is.null(formula)) {
        formula <- ~.
    }
    mdf <- stats::model.frame(formula, data = df, na.action = stats::na.pass)
    which(!stats::complete.cases(mdf))
}

#' Remove Rows with Missing Variables
#'
#' Removes any rows from a data set that contain missing values in the inspected
#' variables. Allows users to specify which variables to inspect for missing values
#' based on either a formula or a character vector of variable names.
#'
#' @typed data: data.frame
#'   input data.
#' @typed formula: "`formula` or `NULL`"
#'   which variables to inspect for missingness.
#' @typed extra_vars: character
#'   additional variables to inspect for missingness.
#'
#' @returns The `data` after removing observations that contain missing values in the required variables.
#'   Note that additional variables not listed in `formula` or `extra_vars` are not dropped and may
#'   still contain missing values.
#'
#' @keywords internal
remove_missing_rows <- function(data, formula, extra_vars = NULL) {
    if (!is.null(extra_vars)) {
        extra_vars <- paste(extra_vars, collapse = " + ")
        formula_update_string <- paste0(". ~ . + ", extra_vars)
        formula <- stats::update(formula, formula_update_string)
    }

    missing_rows <- get_missing_rownumbers(data, formula)

    if (length(missing_rows) == 0) {
        return(data)
    }
    message(sprintf(
        "Note that %d observations were removed as one of more required variables contained missing values",
        length(missing_rows)
    ))
    data_reduced <- data[-missing_rows, ]
    rownames(data_reduced) <- NULL
    data_reduced
}

#' Replicate Single Values in a List
#'
#' @typed initial_values: list
#'   initial values with names.
#' @typed sizes: list
#'   each size corresponds to an element in `initial_values`,
#'   matched by the names. An attribute `array` must be attached to each element,
#'   see [replace_with_lookup()].
#'
#' @returns A named list of values, with any single values in the `initial_values` list
#'   replicated according to the corresponding values in the `sizes` list.
#'   Even when the size is 1, the value is passed as an `array` if the corresponding
#'   attribute is `TRUE` in `sizes`.
#'
#' @note The resulting list has the same names as the original lists.
#'
#' @keywords internal
expand_initial_values <- function(initial_values, sizes) {
    assert_that(
        is.list(initial_values),
        msg = "`initial_values` must be a list"
    )
    assert_that(
        is.list(sizes),
        msg = "`sizes` must be a list"
    )
    assert_that(
        all(names(sizes) %in% names(initial_values)),
        all(names(initial_values) %in% names(sizes)),
        msg = "`initial_values` and `sizes` must have identical names"
    )

    for (name in names(initial_values)) {
        # Check for single values and replicate them according to sizes.
        if (length(initial_values[[name]]) == 1) {
            initial_values[[name]] <- rep(initial_values[[name]], sizes[[name]])
        }
        # Check for array handling.
        needs_array <- attr(sizes[[name]], "array")
        assert_that(
            is.flag(needs_array),
            msg = "each sizes element must have array flag attribute"
        )
        if (needs_array) {
            initial_values[[name]] <- as.array(initial_values[[name]])
        }
    }

    # Check that each element of initial_values has the same length as specified in sizes.
    for (name in names(initial_values)) {
        assert_that(
            length(initial_values[[name]]) == sizes[[name]],
            msg = "length of element in `initial_values` does not match specified size"
        )
    }

    initial_values
}

#' Replace Character Size by Looked Up Numbers
#'
#' @typed sizes: list
#'   may include character elements that correspond to
#'   names in the data list.
#' @typed data: list
#'   data containing numeric values.
#'
#' @returns A list of sizes with character elements in `sizes`
#'   replaced by their corresponding numeric values in `data`.
#'
#' @details An attribute `array` for each returned list element indicates
#'   whether the parameter needs to be handled
#'   as an array. This is the case when the size is larger than 1, or when
#'   the size was looked up in the `data`, because in that case it is flexible
#'   and hence is handled as an array in the Stan code.
#'
#' @note Each element in the final list of sizes must be a single number.
#'
#' @keywords internal
replace_with_lookup <- function(sizes, data) {
    assert_that(is.list(sizes), msg = "`sizes` must be a list")
    assert_that(is.list(data), msg = "`data` must be a list")

    for (idx in seq_along(sizes)) {
        val <- sizes[[idx]]
        if (is.character(val)) {
            assert_that(
                length(val) == 1,
                msg = "character elements of `sizes` must be strings"
            )
            assert_that(
                val %in% names(data),
                msg = sprintf("`%s` is not available in `data`", val)
            )
            new_val <- data[[val]]
            assert_that(
                is.number(new_val),
                msg = "Selected values from data must be single numbers"
            )
            sizes[[idx]] <- structure(new_val, array = TRUE)
        } else {
            assert_that(
                is.number(val),
                msg = "Existing values in sizes must be single numbers"
            )
            sizes[[idx]] <- structure(val, array = val > 1)
        }
    }
    sizes
}

#' Obtain Median and Credible Intervals from MCMC samples
#'
#' @typed samples: matrix
#'   with samples in rows and parameters in columns.
#' @typed level: number
#'   credibility level to use for the credible intervals.
#'
#' @returns A `data.frame` with columns `median`, `lower` and `upper`.
#' @keywords internal
samples_median_ci <- function(samples, level = 0.95) {
    assert_that(is.matrix(samples))
    assert_that(is.number(level), level < 1, level > 0)

    samples_median <- apply(samples, MARGIN = 2L, FUN = stats::median)
    probs <- c((1 - level) / 2, (1 + level) / 2)
    samples_ci <- t(apply(
        samples,
        MARGIN = 2L,
        FUN = stats::quantile,
        probs = probs
    ))
    colnames(samples_ci) <- c("lower", "upper")
    as.data.frame(cbind(
        median = samples_median,
        samples_ci
    ))
}


#' `decorated_render`
#'
#' Simple wrapper around [jinjar::render()] that provides some additional default
#' variables about the system (avoids each call to jinjar having to specify them)
#' @param ... Arguments passed onto [jinjar::render()]
#' @returns See [jinjar::render()]
#' @keywords internal
decorated_render <- function(...) {
    jinjar::render(
        ...,
        machine_double_eps = 0,
        machine_double_neg_eps = 0
    )
}


is_windows <- function() {
    sysname <- Sys.info()["sysname"]
    return(sysname == "Windows")
}

#' `validate_time_grid`
#'
#' Validate that the provided time grid is:
#' - finite
#' - numeric
#' - non-missing
#' - sorted
#' - unique
#'
#' @typed time_grid: numeric
#'   A vector of times which quantities will be
#'   evaluated at.
#'
#' @keywords internal
validate_time_grid <- function(time_grid) {
    assert_that(
        !any(is.na(time_grid)),
        is.numeric(time_grid),
        !is.null(time_grid),
        !is.unsorted(time_grid),
        !any(duplicated(time_grid)),
        all(is.finite(time_grid)),
        msg = "`time_grid` needs to be finite, sorted, unique valued numeric vector"
    )
    invisible(time_grid)
}


#' `expand_subjects`
#'
#' This function checks and expands a given subjects vector.
#' The input vector must be unique and contain only values
#' as specified by `all_subjects`
#'
#' @typed subjects: "`character` or `NULL`"
#'   Character vector representing the subjects.
#'   If NULL, it will be set to the value of `all_subjects`.
#' @typed all_subjects: character
#'   Character vector representing all possible subjects.
#' @return Returns the expanded `subjects` vector.
#' @keywords internal
expand_subjects <- function(subjects, all_subjects) {
    assert_that(
        is.character(all_subjects),
        msg = "`all_subjects` must be a character vector"
    )
    if (is.null(subjects)) {
        subjects <- unique(all_subjects)
    }
    assert_that(
        is.character(subjects),
        all(subjects %in% all_subjects),
        !any(duplicated(subjects)),
        msg = "`subjects` should be a unique character vector containing only values from the original df"
    )
    return(subjects)
}


#' Decompose subjects into Relevant Components
#'
#' This function takes in a character vector or list of subjects and decomposes it into a
#' structured format.
#'
#' The primary use of this function is to correctly setup indexing variables for
#' predicting survival quantities (see [SurvivalQuantities()])
#'
#' @typed subjects: "`character` or `list`"
#'   subject identifiers. If `NULL` will be set to `all_subjects`.
#'
#' @typed all_subjects: character
#'   the set of allowable subject identifiers.
#'   Will cause an error if any value of `subjects` is not in this vector.
#'
#' @return A list containing three components:
#' - `groups`: (`list`)\cr each element of the list is a character vector
#' specifying which subjects belong to a given "group" where the "group" is the element name
#' - `unique_values`: (`character`)\cr vector of the unique subjects within `subjects`
#' - `indexes`: (`list`)\cr each element is a named and is a numeric index vector
#' that maps the values of `grouped` to `unique_values`
#' @examples
#' \dontrun{
#' result <- decompose_subjects(c("A", "B"), c("A", "B", "C", "D"))
#' result <- decompose_subjects(
#'     list("g1" = c("A", "B"), "g2" = c("B", "C")),
#'     c("A", "B", "C", "D")
#'   )
#' }
#' @seealso [expand_subjects()], [SurvivalQuantities()]
#' @keywords internal
decompose_subjects <- function(subjects, all_subjects) {
    if (is.character(subjects) || is.null(subjects)) {
        subjects <- expand_subjects(subjects, all_subjects)
        names(subjects) <- subjects
        subjects <- as.list(subjects)
    }
    subjects <- lapply(
        subjects,
        expand_subjects,
        all_subjects = all_subjects
    )
    assert_that(
        is.list(subjects),
        length(unique(names(subjects))) == length(subjects),
        all(vapply(subjects, is.character, logical(1)))
    )
    subjects_vec_unordered <- unique(unlist(subjects))
    subjects_vec <- subjects_vec_unordered[order(subjects_vec_unordered)]
    subjects_lookup <- stats::setNames(seq_along(subjects_vec), subjects_vec)
    subjects_index <- lapply(
        subjects,
        \(x) {
            z <- subjects_lookup[x]
            names(z) <- NULL
            z
        }
    )
    list(
        groups = subjects,
        unique_values = subjects_vec,
        indexes = subjects_index
    )
}

is_cmdstanr_available <- function() {
    requireNamespace("cmdstanr", quietly = TRUE)
}


is_connection <- function(obj) {
    inherits(obj, "connection")
}

#' @include Grid.R
#' @include generics.R
NULL

#' @rdname Grid-Dev
.GridEvent <- setClass(
    "GridEvent",
    contains = "Grid",
    slots = c(
        "subjects" = "character_or_NULL"
    )
)


#' @rdname Grid-Functions
#' @export
GridEvent <- function(subjects = NULL) {
    .GridEvent(
        subjects = subjects
    )
}

#' @rdname Quant-Dev
#' @export
as.QuantityGenerator.GridEvent <- function(object, data, ...) {
    assert_class(data, "DataJoint")
    assert_that(
        !is.null(data@survival),
        msg = "Survival data must have been provided to `DataJoint()` in order to use `GridEvent()`"
    )
    data_list <- as.list(data)
    subjects <- unlist(as.list(object, data = data), use.names = FALSE)
    event_times <- data_list$event_times[data_list$subject_to_index[subjects]]
    QuantityGeneratorSubject(
        times = event_times,
        subjects = subjects
    )
}

#' @rdname Quant-Dev
#' @export
as.QuantityCollapser.GridEvent <- function(object, data, ...) {
    generator <- as.QuantityGenerator(object, data)
    QuantityCollapser(
        times = generator@times,
        groups = generator@subjects,
        indexes = as.list(seq_along(generator@times))
    )
}

#' @export
as.list.GridEvent <- function(x, data, ...) {
    subjects_to_list(x@subjects, data)
}

#' Re-used documentation for `RandomEffectQuantities`
#'
#' @typed x: RandomEffectQuantities
#'   generated quantities.
#' @typed object: RandomEffectQuantities
#'   generated quantities.
#' @typed conf.level: numeric
#'   confidence level of the interval.
#' @param ... not used.
#'
#' @keywords internal
#' @name RandomEffectQuantities-Shared
NULL


#' Random Effects Quantities Container
#'
#' A simple wrapper around a `matrix` to store required metadata for patient level
#' random effects data
#'
#' @typed quantities: matrix
#'   of random effects values.
#' @typed subject: character
#'   labels specifying which subjects the values belong to.
#' @typed parameter: character
#'   labels specifying which parameter the value is.
#'
#' @slot quantities (`matrix`)\cr See Arguments for details.
#' @slot subject (`numeric`)\cr See Arguments for details.
#' @slot parameter (`character`)\cr See Arguments for details.
#'
#' @details
#' Each row of the matrix represents a sample and each column represents a distinct subject
#' specific parameter.
#' As such the number of columns in the matrix should equal the length of `subject` and `parameter`
#' which provide metadata for who the parameter corresponds to as well as which parameter it is.
#'
#' @keywords internal
#' @name RandomEffectQuantities-class
#' @family RandomEffectQuantities
.RandomEffectQuantities <- setClass(
    "RandomEffectQuantities",
    slots = list(
        "quantities" = "matrix",
        "subject" = "character",
        "parameter" = "character"
    )
)
#' @rdname RandomEffectQuantities-class
RandomEffectQuantities <- function(quantities, subject, parameter) {
    .RandomEffectQuantities(
        quantities = quantities,
        subject = subject,
        parameter = parameter
    )
}

setValidity(
    Class = "RandomEffectQuantities",
    method = function(object) {
        if (length(object@subject) != ncol(object@quantities)) {
            return(
                "Length of `subject` must be equal to the number of columns in `quantities`"
            )
        }
        if (length(object@parameter) != ncol(object@quantities)) {
            return(
                "Length of `parameter` must be equal to the number of columns in `quantities`"
            )
        }
        TRUE
    }
)


#' `RandomEffectQuantities` -> Printable `Character`
#'
#' Converts [`RandomEffectQuantities`] object into a printable string.
#' @inheritParams RandomEffectQuantities-Shared
#' @typed indent: numeric
#'   the number of spaces to indent the string by.
#' @family RandomEffectQuantities
#' @keywords internal
#' @export
as_print_string.RandomEffectQuantities <- function(object, indent = 1, ...) {
    parameter_string <- paste0("        ", unique(object@parameter))
    template <- c(
        "RandomEffectQuantities Object:",
        "    # of samples         = %d",
        "    # of unique subjects = %d",
        "    For parameters:",
        parameter_string
    )
    pad <- rep(" ", indent) |> paste(collapse = "")
    template_padded <- paste(pad, template)
    sprintf(
        paste(template_padded, collapse = "\n"),
        nrow(object@quantities),
        length(unique(object@subject))
    )
}


#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "RandomEffectQuantities",
    definition = function(object) {
        string <- as_print_string(object)
        cat("\n", string, "\n\n")
    }
)


#' `RandomEffectQuantities` -> `data.frame`
#'
#' Returns a `data.frame` of the subject-level random effect parameter samples.
#'
#' @inheritParams RandomEffectQuantities-Shared
#'
#' @keywords internal
#' @family RandomEffectQuantities
#' @export
as.data.frame.RandomEffectQuantities <- function(x, ...) {
    data.frame(
        subject = rep(x@subject, each = nrow(x@quantities)),
        parameter = rep(x@parameter, each = nrow(x@quantities)),
        values = as.vector(x@quantities)
    )
}


#' summary
#'
#' @description
#' This method returns a summary statistic `data.frame` of the random effect parameters
#'
#' @inheritParams RandomEffectQuantities-Shared
#'
#' @returns
#' A `data.frame` with the following variables:
#' - `subject` (`character`) \cr the subject identifier.
#' - `parameter` (`character`) \cr the parameter identifier.
#' - `median` (`numeric`) \cr the median value of the quantity.
#' - `lower` (`numeric`) \cr the lower CI value of the quantity.
#' - `upper` (`numeric`) \cr the upper CI value of the quantity.
#'
#' @keywords internal
#' @family RandomEffectQuantities
#' @export
summary.RandomEffectQuantities <- function(object, conf.level = 0.95, ...) {
    quantities_summarised <- samples_median_ci(
        object@quantities,
        level = conf.level
    )

    quantities_summarised$subject <- object@subject
    quantities_summarised$parameter <- object@parameter
    quantities_summarised[, c(
        "subject",
        "parameter",
        "median",
        "lower",
        "upper"
    )]
}


#' Extract Random Effects Samples from a Longitudinal Model
#'
#' Helper function to extract subject-level random effects samples from the longitudinal
#' sub-model of a joint model samples object.
#'
#' @typed object: JointModelSamples
#'   samples as drawn from a Joint Model.
#' @family RandomEffectQuantities
#' @family JointModelSamples
#' @export
LongitudinalRandomEffects <- function(object) {
    assert_class(object, "JointModelSamples")

    subject_indexes <- as.list(object@data)$subject_to_index
    random_effects_names <- getRandomEffectsNames(object@model)
    expanded <- expand.grid(
        parameter_long = random_effects_names,
        subject_indexes = subject_indexes
    )
    expanded$subject <- names(subject_indexes)[expanded$subject_indexes]
    expanded$parameter <- names(random_effects_names)[expanded$parameter_long]
    stan_parameter_names <- sprintf(
        "%s[%i]",
        expanded$parameter_long,
        expanded$subject_indexes
    )
    draw_matrix <- posterior::as_draws_matrix(object@results$draws(
        stan_parameter_names
    ))
    class(draw_matrix) <- "matrix"
    rownames(draw_matrix) <- NULL
    colnames(draw_matrix) <- NULL

    RandomEffectQuantities(
        draw_matrix,
        subject = expanded$subject,
        parameter = expanded$parameter
    )
}

#' @include Grid.R
#' @include generics.R
NULL


#' @rdname Grid-Dev
.GridManual <- setClass(
    "GridManual",
    contains = "Grid",
    slots = c(
        "spec" = "list"
    )
)


#' @rdname Grid-Functions
#' @export
GridManual <- function(spec) {
    .GridManual(
        spec = spec
    )
}


setValidity(
    "GridManual",
    function(object) {
        subject_names <- names(object@spec)
        subject_names_valid <- subject_names[
            !is.na(subject_names) & subject_names != ""
        ]
        if (length(subject_names_valid) != length(object@spec)) {
            return("Each element of `subjects` must be named")
        }
        for (times in object@spec) {
            if (!is.numeric(times)) {
                return("Each element of `spec` must be a numeric vector")
            }
            if (length(times) != length(unique(times))) {
                return("Each time vector per subject must be unique")
            }
        }
        return(TRUE)
    }
)


#' @rdname Quant-Dev
#' @export
as.QuantityGenerator.GridManual <- function(object, data, ...) {
    assert_class(data, "DataJoint")
    data_list <- as.list(data)
    assert_that(
        all(names(object@spec) %in% names(data_list$subject_to_index)),
        msg = "All subject names must be in the `DataSubject` object"
    )
    lens <- vapply(object@spec, length, numeric(1))
    QuantityGeneratorSubject(
        times = unlist(object@spec, use.names = FALSE),
        subjects = rep(names(object@spec), lens)
    )
}


#' @rdname Quant-Dev
#' @export
as.QuantityCollapser.GridManual <- function(object, data, ...) {
    generator <- as.QuantityGenerator(object, data)
    QuantityCollapser(
        times = generator@times,
        groups = generator@subjects,
        indexes = as.list(seq_along(generator@times))
    )
}


#' @export
as.list.GridManual <- function(x, data, ...) {
    subs <- as.list(names(x@spec))
    names(subs) <- names(x@spec)
    subs
}

#' @include generics.R
#' @include Grid.R
NULL

#' @rdname Quant-Dev
.QuantityGeneratorPrediction <- setClass(
    "QuantityGeneratorPrediction",
    contains = "QuantityGenerator",
    slots = c(
        "times" = "numeric",
        "newdata" = "data.frame",
        "params" = "list"
    )
)


#' @rdname Quant-Dev
QuantityGeneratorPrediction <- function(times, newdata = NULL, params = NULL) {
    .QuantityGeneratorPrediction(
        times = times,
        newdata = newdata,
        params = params
    )
}
setValidity(
    "QuantityGeneratorPrediction",
    function(object) {
        if (length(object@times) != nrow(object@newdata)) {
            return("Length of `times` and `newdata` must be equal")
        }
        return(TRUE)
    }
)


#' @rdname as_stan_list.QuantityGenerator
#' @export
as_stan_list.QuantityGeneratorPrediction <- function(object, data, model, ...) {
    assert_that(
        is(data, "DataJoint")
    )
    ret <- list()
    data_list <- as_stan_list(data)

    ret[["gq_times"]] <- object@times
    ret[["gq_n_quant"]] <- length(object@times)

    # Get a list of which longutidunal parameters need to be defined based
    # on the selected longitudinal model
    par_names <- getPredictionNames(model@longitudinal)
    for (nam in par_names) {
        assert_that(
            nam %in% names(object@params),
            msg = sprintf("Parameter '%s' not found in `params`", nam)
        )
        assert_that(
            is.numeric(object@params[[nam]]),
            msg = sprintf("Parameter '%s' must be numeric", nam)
        )
        assert_that(
            length(object@params[[nam]]) == 1,
            msg = sprintf("Parameter '%s' must be length 1", nam)
        )
    }

    par_vals <- object@params[par_names]
    if (length(par_vals) == 0) {
        par_vals <- 0
        par_names <- "null_model"
    }

    ret[["gq_n_par"]] <- length(par_names)

    # Replicate the longitudinal parameters so the same parameter values are used
    # for all observations that are being predicted
    ret[["gq_link_function_inputs"]] <- matrix(
        rep(unlist(par_vals), each = ret[["gq_n_quant"]]),
        ncol = ret[["gq_n_par"]],
        nrow = ret[["gq_n_quant"]]
    )

    # Create design matrix from new data ensuring that it has the same
    # structure as the original design matrix
    ret[["gq_os_cov_design"]] <- mirror_design_matrix(
        data@survival,
        object@newdata
    )

    # dummy pop indexes in order for stan code to actualy compile. In this setting
    # this matrix isn't actually used so doesn't matter what these values are
    # but don't want to have to burden individual longitudinal models with the
    # conditional logic to check if they are generating population quantities or not
    ret[["gq_long_pop_arm_index"]] <- rep(1, ret[["gq_n_quant"]])
    ret[["gq_long_pop_study_index"]] <- rep(1, ret[["gq_n_quant"]])

    # Sanity checks
    assert_that(
        nrow(ret[["gq_os_cov_design"]]) == ret[["gq_n_quant"]],
        ncol(ret[["gq_os_cov_design"]]) == data_list[["p_os_cov_design"]],
        all(!is.na(ret[["gq_link_function_inputs"]]))
    )

    return(ret)
}

#' Simulate Patients from Posterior Predictive Distribution
#' @param object A [JointModelSamples] object
#' @param newdata A data frame containing data in the same format as
#'  the `object@data@survival@data`. Importantly, it should contain the same covariates and factor levels
#'    as the variables used in the survival formula `object@data@survival@formula` and
#'  the same columns used for `study`, `id`, and `arm`.
#' @param ... Unused.
#' @param times Vector of times to simulate SLD for all patients.
#' @param jitter_var Vector of variances to add noise to the observed SLD `times`. The first value is for any times
#'   less than 0 and the second for any times after 0. All positive (negative) times will remain positive (negative).
#'    Jitter values are generated from a normal distribution with mean 0 and the given variances.
#' @typed time_max: number
#'   the maximum time to simulate to.
#' @typed time_step: number
#'   the time interval between evaluating the log-hazard function.
#' @typed lambda_censor: number
#'   the censoring rate, as the parameter of an exponential distribution.
#' @param scaled_variance Should variance be scaled by the expected value. Must be set the same as was used for
#' model fitting.
#' @param seed Ignored.
#' @param nsim Ignored.
#' @details Simulates a set of patients based on the covariates of those
#' used in the model fit or from `newdata`, which must contain the
#' same column names and factor levels.
#'
#' @importFrom stats simulate
#' @export
simulate.JointModelSamples <- function(
    object,
    nsim = NULL,
    seed = NULL,
    newdata = NULL,
    times = c(-2, 0, 10, 50, 100),
    jitter_var = c(0, 0),
    time_max = 2000,
    time_step = 1,
    lambda_censor = 1 / 3000,
    scaled_variance = TRUE,
    ...
) {
    subj_data <- if (is.null(newdata)) {
        dplyr::left_join(
            object@data@subject@data[, c(
                object@data@subject@subject,
                object@data@subject@arm,
                object@data@subject@study
            )],
            object@data@survival@data[, c(
                object@data@subject@subject,
                all.vars(delete.response(terms(object@data@survival@formula)))
            )],
            by = object@data@subject@subject
        )
    } else {
        newdata
    }

    subject_data <- DataSubject(
        subj_data,
        subject = object@data@subject@subject,
        arm = object@data@subject@arm,
        study = object@data@subject@study
    )

    n_patients <- nrow(subject_data@data)

    requiredVars <- list(
        longitudinal = lapply(
            object@model@survival@parameters@parameters,
            function(x) x@name
        ),
        survival = lapply(
            object@model@longitudinal@parameters@parameters,
            function(x) x@name
        ),
        link = lapply(object@model@link@components, function(x) x@key)
    )

    draws <- object@results$draws(
        variables = unlist(requiredVars),
        format = "draws_matrix"
    )
    draw_id <- sample.int(nrow(draws), n_patients, replace = FALSE)

    long_models <- list()
    surv_models <- list()
    for (i in seq.int(n_patients)) {
        draw <- draws[draw_id[i], ]
        long_models[[i]] <- createLongitudinalSimObject(
            object@model@longitudinal,
            draw,
            times = add_jitter(times, jitter_var = jitter_var),
            scaled_variance = scaled_variance
        )
        surv_models[[i]] <- createSurvivalSimObject(
            object@model@survival,
            draw,
            lambda_censor = lambda_censor,
            time_step = time_step,
            time_max = time_max
        )
    }

    SimJointDataResults(
        subject = subject_data,
        surv_formula = object@data@survival@formula,
        longitudinal = long_models,
        survival = surv_models
    )
}


add_jitter <- function(times, jitter_var = c(0, 0)) {
    stopifnot(all(jitter_var >= 0))
    if (jitter_var[1] > 0) {
        neg_times <- times < 0
        times[neg_times] <- pmin(
            times[neg_times] + rnorm(sum(neg_times), sd = sqrt(jitter_var[1])),
            -.Machine$double.eps / 2
        )
    }
    if (jitter_var[2] > 0) {
        pos_times <- times > 0
        times[pos_times] <- pmax(
            times[pos_times] + rnorm(sum(pos_times), sd = sqrt(jitter_var[2])),
            .Machine$double.eps / 2
        )
    }
    times
}


# Longitudinal Sim Object constructors --------
#' @noRd
createLongitudinalSimObject <- function(object, draw, ...) {
    UseMethod("createLongitudinalSimObject")
}

#' Get draws value by name
#' @param draws matrix
#' @param name character to match column names of `draws` with [startsWith]
#' @return A vector of matching values or `NULL` if no match.
#' @noRd
get_vars <- function(draws, name) {
    result <- as.numeric(draws[, startsWith(colnames(draws), name)])
    if (length(result) == 0) {
        NULL
    } else {
        result
    }
}

#' @exportS3Method
createLongitudinalSimObject.LongitudinalRandomSlope <- function(
    object,
    draw,
    ...
) {
    args <- list(...)

    args$intercept <- get_vars(draw, "lm_rs_intercept")
    args$slope_mu <- get_vars(draw, "lm_rs_slope_mu")
    args$slope_sigma <- get_vars(draw, "lm_rs_slope_sigma")
    args$sigma <- get_vars(draw, "lm_rs_sigma")
    args$link_dsld <- get_vars(draw, "link_dsld")
    args$link_identity <- get_vars(draw, "link_identity")
    args$scaled_variance <- NULL # not defined for random slope
    do.call(SimLongitudinalRandomSlope, args)
}

#' @exportS3Method
createLongitudinalSimObject.LongitudinalSteinFojo <- function(
    object,
    draw,
    ...
) {
    args <- list(...)
    args$sigma <- get_vars(draw, "lm_sf_sigma")
    args$mu_s <- get_vars(draw, "lm_sf_mu_ks")
    args$mu_g <- get_vars(draw, "lm_sf_mu_kg")
    args$mu_b <- get_vars(draw, "lm_sf_mu_bsld")
    args$omega_s <- get_vars(draw, "lm_sf_omega_ks")
    args$omega_g <- get_vars(draw, "lm_sf_omega_kg")
    args$omega_b <- get_vars(draw, "lm_sf_omega_bsld")
    args$link_dsld <- get_vars(draw, "link_dsld")
    args$link_ttg <- get_vars(draw, "link_ttg")
    args$link_identity <- get_vars(draw, "link_identity")
    args$link_growth <- get_vars(draw, "link_growth")
    args$link_shrinkage <- get_vars(draw, "link_shrinkage")
    do.call(SimLongitudinalSteinFojo, args)
}

#' @exportS3Method
createLongitudinalSimObject.LongitudinalGSF <- function(object, draw, ...) {
    args <- list(...)
    args$sigma <- get_vars(draw, "lm_gsf_sigma")
    args$mu_s <- get_vars(draw, "lm_gsf_mu_ks")
    args$mu_g <- get_vars(draw, "lm_gsf_mu_kg")
    args$mu_b <- get_vars(draw, "lm_gsf_mu_bsld")
    args$mu_phi <- get_vars(draw, "lm_gsf_mu_phi")
    args$omega_s <- get_vars(draw, "lm_gsf_omega_ks")
    args$omega_g <- get_vars(draw, "lm_gsf_omega_kg")
    args$omega_b <- get_vars(draw, "lm_gsf_omega_bsld")
    args$omega_phi <- get_vars(draw, "lm_gsf_omega_phi")
    args$link_dsld <- get_vars(draw, "link_dsld")
    args$link_ttg <- get_vars(draw, "link_ttg")
    args$link_identity <- get_vars(draw, "link_identity")
    args$link_growth <- get_vars(draw, "link_growth")
    args$link_shrinkage <- get_vars(draw, "link_shrinkage")

    do.call(SimLongitudinalGSF, args)
}

#' @exportS3Method
createLongitudinalSimObject.LongitudinalClaretBruno <- function(
    object,
    draw,
    ...
) {
    args <- list(...)
    args$sigma <- get_vars(draw, "lm_clbr_sigma")
    args$mu_b <- get_vars(draw, "lm_clbr_mu_b")
    args$mu_g <- get_vars(draw, "lm_clbr_mu_g")
    args$mu_c <- get_vars(draw, "lm_clbr_mu_c")
    args$mu_p <- get_vars(draw, "lm_clbr_mu_p")
    args$omega_b <- get_vars(draw, "lm_clbr_omega_b")
    args$omega_g <- get_vars(draw, "lm_clbr_omega_g")
    args$omega_c <- get_vars(draw, "lm_clbr_omega_c")
    args$omega_p <- get_vars(draw, "lm_clbr_omega_p")
    args$link_dsld <- get_vars(draw, "link_dsld")
    args$link_ttg <- get_vars(draw, "link_ttg")
    args$link_identity <- get_vars(draw, "link_identity")
    args$link_growth <- get_vars(draw, "link_growth")
    args$link_shrinkage <- get_vars(draw, "link_shrinkage")
    do.call(SimLongitudinalClaretBruno, args)
}


# Survival Sim Object constructors --------

#' @noRd
createSurvivalSimObject <- function(object, draw, ...) {
    UseMethod("createSurvivalSimObject")
}

#' @exportS3Method
createSurvivalSimObject.SurvivalWeibullPH <- function(object, draw, ...) {
    args <- list(...)
    args$lambda <- get_vars(draw, "sm_weibull_ph_lambda")
    args$gamma <- get_vars(draw, "sm_weibull_ph_gamma")

    result <- do.call(SimSurvivalWeibullPH, args)
    result@beta_os_cov <- get_vars(draw, "beta_os_cov")
    result
}

#' @exportS3Method
createSurvivalSimObject.SurvivalExponential <- function(object, draw, ...) {
    args <- list(...)
    args$lambda <- get_vars(draw, "sm_exp_lambda")

    result <- do.call(SimSurvivalExponential, args)
    result@beta_os_cov <- get_vars(draw, "beta_os_cov")
    result
}

#' @exportS3Method
createSurvivalSimObject.SurvivalGamma <- function(object, draw, ...) {
    lapply(object@model@survival@parameters@parameters, function(x) x@name)
    lapply(object@model@link@components, function(x) x@key)
    args <- list(...)
    args$k <- get_vars(draw, "sm_gamma_k")
    args$theta <- get_vars(draw, "sm_gamma_theta")

    result <- do.call(SimSurvivalGamma, args)
    result@beta_os_cov <- get_vars(draw, "beta_os_cov")
    result
}

#' @exportS3Method
createSurvivalSimObject.SurvivalLogLogistic <- function(object, draw, ...) {
    lapply(object@model@survival@parameters@parameters, function(x) x@name)
    lapply(object@model@link@components, function(x) x@key)
    args <- list(...)
    args$a <- get_vars(draw, "sm_loglogis_a")
    args$b <- get_vars(draw, "sm_loglogis_b")

    result <- do.call(SimSurvivalLogLogistic, args)
    result@beta_os_cov <- get_vars(draw, "beta_os_cov")
    result
}


sampleSubjectsFromObs <- function(object, subjects_df, covs_matrix) {
    subjects_df$log_haz_cov <- rowSums(
        covs_matrix[, -1] * t(sapply(object, function(x) x@beta_os_cov))
    )
    subjects_df |>
        dplyr::mutate(survival = stats::runif(dplyr::n())) |>
        dplyr::mutate(chazard_limit = -log(.data$survival)) |>
        dplyr::mutate(
            time_cen = stats::rexp(
                dplyr::n(),
                sapply(object, function(x) x@lambda_censor)
            )
        )
}

# Simulate patient function ------
SimJointDataResults <- function(
    subject,
    surv_formula,
    longitudinal,
    survival,
    .silent = FALSE
) {
    # take hazard windows from first element. All have the same
    # @time_step and @time_max parameters
    hazard_evaluation_info <- hazardWindows(survival[[1]])

    group_counts <- as.data.frame(table(subject@data[, c(
        subject@study,
        subject@arm
    )]))

    n_group <- group_counts$Freq
    arms <- group_counts[, 2]
    studies <- group_counts[, 1]
    n_subjects <- sum(n_group)
    n_times <- length(hazard_evaluation_info$midpoint)

    baseline <- data.frame(
        subject = subject@data[[subject@subject]],
        study = subject@data[[subject@study]],
        arm = subject@data[[subject@arm]]
    )

    cov_cols <- cbind(
        subject = subject@data[[subject@subject]],
        subject@data[, all.vars(delete.response(terms(surv_formula)))]
    )

    os_baseline <- sampleSubjectsFromObs(
        survival,
        subjects_df = baseline,
        model.matrix(delete.response(terms(surv_formula)), subject@data)
    )

    lm_baseline <- dplyr::bind_rows(
        lapply(seq.int(longitudinal), function(i) {
            sampleSubjects(longitudinal[[i]], subjects_df = baseline[i, ])
        })
    )

    lm_times <- lapply(seq.int(longitudinal), function(i) {
        longitudinal[[i]]@times
    })

    lm_dat_no_obvs <-
        cbind(
            baseline[rep(seq.int(nrow(baseline)), times = lengths(lm_times)), ],
            time = unlist(lm_times)
        ) |>
        dplyr::left_join(lm_baseline, by = c("subject", "study", "arm"))

    lm_dat <- dplyr::bind_rows(
        .mapply(
            sampleObservations,
            dots = list(
                times_df = split(lm_dat_no_obvs, ~subject),
                object = longitudinal
            ),
            MoreArgs = NULL
        )
    )

    hazard_eval_df <- dplyr::tibble(
        subject = rep(lm_baseline$subject, each = n_times),
        arm = rep(lm_baseline$arm, each = n_times),
        study = rep(lm_baseline$study, each = n_times),
        midpoint = rep(
            as.double(hazard_evaluation_info$midpoint),
            times = n_subjects
        ),
        time = rep(as.double(hazard_evaluation_info$upper), times = n_subjects),
        width = rep(as.double(hazard_evaluation_info$width), times = n_subjects)
    )

    lm_link_dat <- dplyr::bind_rows(
        .mapply(
            sampleObservations,
            dots = list(
                times_df = split(
                    dplyr::left_join(
                        hazard_eval_df,
                        lm_baseline,
                        by = c("subject", "study", "arm")
                    ),
                    ~subject
                ),
                object = longitudinal
            ),
            MoreArgs = NULL
        )
    )[, c(
        "subject",
        "study",
        "arm",
        "log_haz_link",
        "time",
        "width",
        "midpoint"
    )]

    os_eval_df <- lm_link_dat |>
        dplyr::left_join(os_baseline, by = c("subject", "study", "arm"))

    times_df <- split(os_eval_df, ~subject)
    os_data_list <- list()
    for (i in seq_along(times_df)) {
        times_df[[i]]$log_bl_haz <- survival[[i]]@loghazard(
            times_df[[i]]$midpoint
        )
    }
    os_dat <- sampleObservations2(dplyr::bind_rows(times_df))

    os_dat <- dplyr::left_join(os_dat, cov_cols, by = "subject")

    lm_dat2 <- lm_dat |>
        dplyr::left_join(
            dplyr::select(os_dat, "subject", os_time = "time"),
            by = "subject"
        ) |>
        dplyr::mutate(observed = (.data$time <= .data$os_time)) |>
        dplyr::arrange(dplyr::pick(c("subject", "time")))

    assert_that(
        length(unique(os_dat$subject)) == length(os_dat$subject),
        length(os_dat$subject) == n_subjects,
        all(os_dat$time >= 0),
        all(os_dat$event %in% c(0, 1)),
        msg = "Assumptions for the Survival data are not met (please report this issue)"
    )

    assert_that(
        nrow(lm_dat2) == n_subjects * length(longitudinal[[1]]@times),
        length(unique(lm_dat2$subject)) == n_subjects,
        msg = "Assumptions for the Longitudinal data are not met (please report this issue)"
    )

    original_names <- c("subject", "arm", "study")
    names(original_names) <- c(subject@subject, subject@arm, subject@study)

    return(
        .SimJointData(
            survival = os_dat |> dplyr::rename(dplyr::all_of(original_names)),
            longitudinal = lm_dat2[, c(
                "subject",
                "arm",
                "study",
                "time",
                "sld",
                "observed"
            )] |>
                dplyr::rename(dplyr::all_of(original_names))
        )
    )
}


# adapted from sampleObservations so that $midpoint and $log_bl_haz are already in times_df.
sampleObservations2 <- function(times_df) {
    assert_that(
        all(times_df$time >= 0),
        msg = "All time points must be greater than or equal to 0"
    )

    os_dat_chaz <- times_df |>
        # Fix to avoid issue with log(0) = NaN values
        dplyr::mutate(
            log_bl_haz = dplyr::if_else(
                .data$midpoint == 0,
                -999,
                .data$log_bl_haz
            ),
            hazard_instant = exp(
                .data$log_bl_haz + .data$log_haz_cov + .data$log_haz_link
            ),
            # Reset Inf values to large number to avoid NaN issues downstream
            # This is suitable as Hazard limits tend to be in the range of -10 to 10 so large numbers
            # are essentially equivalent to infinity for simulation purposes
            hazard_instant = dplyr::if_else(
                .data$hazard_instant == Inf,
                999,
                .data$hazard_instant
            ),
            hazard_instant = dplyr::if_else(
                .data$hazard_instant == -Inf,
                -999,
                .data$hazard_instant
            ),
            hazard_interval = .data$hazard_instant * .data$width
        ) |>
        dplyr::mutate(chazard = cumsum(.data$hazard_interval), .by = "subject")

    os_had_event <- os_dat_chaz |>
        dplyr::filter(.data$chazard >= .data$chazard_limit) |>
        dplyr::slice_head(by = "subject") |>
        dplyr::mutate(event = 1)

    os_had_censor <- os_dat_chaz |>
        dplyr::filter(!.data$subject %in% os_had_event$subject) |>
        dplyr::slice_tail(by = "subject") |>

        dplyr::mutate(event = 0)

    if (!(nrow(os_had_censor) == 0)) {
        message(sprintf(
            "INFO: %i subject(s) did not die before max(times)",
            nrow(os_had_censor)
        ))
    }

    os_dat_complete <- os_had_event |>
        dplyr::bind_rows(os_had_censor) |>
        dplyr::mutate(
            real_time = .data$time,
            event = dplyr::if_else(
                .data$real_time <= .data$time_cen,
                .data$event,
                0
            ),
            time = dplyr::if_else(
                .data$real_time <= .data$time_cen,
                .data$real_time,
                .data$time_cen
            )
        ) |>
        dplyr::arrange(.data$subject)

    keep_cols <- colnames(os_dat_complete) %in%
        c("subject", "study", "arm", "time", "event", "cov_cont", "cov_cat")
    os_dat_complete[, keep_cols]
}

#' @include Grid.R
#' @include GridFixed.R
#' @include generics.R
NULL

#' @rdname Grid-Dev
.GridGrouped <- setClass(
    "GridGrouped",
    contains = "Grid",
    slots = c(
        "groups" = "list",
        "times" = "numeric_or_NULL"
    )
)

#' @rdname Grid-Functions
#' @export
GridGrouped <- function(groups, times = NULL) {
    .GridGrouped(
        groups = groups,
        times = times
    )
}


setValidity(
    "GridGrouped",
    function(object) {
        if (!all(vapply(object@groups, is.character, logical(1)))) {
            return("Each element of `groups` must be a character vector")
        }
        gnames <- names(object@groups)
        gnames <- gnames[!is.na(gnames) & gnames != ""]
        if (length(gnames) != length(object@groups)) {
            return("Each element of `groups` must be named")
        }
        return(TRUE)
    }
)


#' @rdname Quant-Dev
#' @export
as.QuantityGenerator.GridGrouped <- function(object, data, ...) {
    assert_class(data, "DataJoint")
    data_list <- as.list(data)
    subjects_unique <- unique(unlist(object@groups))
    assert_that(
        all(subjects_unique %in% names(data_list$subject_to_index))
    )
    as.QuantityGenerator(
        GridFixed(
            times = object@times,
            subjects = subjects_unique
        ),
        data = data
    )
}


#' @rdname Quant-Dev
#' @export
as.QuantityCollapser.GridGrouped <- function(object, data, ...) {
    assert_class(data, "DataJoint")
    data_list <- as.list(data)
    assert_that(
        all(
            unique(unlist(object@groups)) %in% names(data_list$subject_to_index)
        )
    )

    validate_time_grid(object@times)

    group_grid <- expand.grid(
        group = names(object@groups),
        time = object@times,
        stringsAsFactors = FALSE
    )

    generator <- as.QuantityGenerator(object, data)

    select_indexes <- mapply(
        function(group, time) {
            correct_subject <- generator@subjects %in% object@groups[[group]]
            correct_time <- generator@times == time
            seq_along(correct_time)[correct_subject & correct_time]
        },
        group_grid$group,
        group_grid$time,
        SIMPLIFY = FALSE
    )
    names(select_indexes) <- NULL

    QuantityCollapser(
        times = group_grid$time,
        groups = group_grid$group,
        indexes = select_indexes
    )
}

#' @export
as.list.GridGrouped <- function(x, ...) {
    x@groups
}

#' @rdname coalesceGridTime
#' @export
coalesceGridTime.GridGrouped <- function(object, times, ...) {
    if (is.null(object@times)) {
        object <- GridGrouped(
            groups = object@groups,
            times = times
        )
    }
    object
}

#' @include JointModel.R
#' @include SurvivalQuantities.R
NULL

setOldClass("CmdStanMCMC")

# JointModelSamples-class ----

#' `JointModelSamples`
#'
#' Contains samples from a [`JointModel`].
#'
#' @slot model ([`JointModel`])\cr the model that the samples were drawn from.
#' @slot data ([`DataJoint`])\cr the data that the model was fitted on.
#' @slot results ([`cmdstanr::CmdStanMCMC`])\cr the STAN samples.
#'
#' @aliases JointModelSamples
#' @export
.JointModelSamples <- setClass(
    "JointModelSamples",
    slots = c(
        model = "JointModel",
        data = "DataJoint",
        results = "CmdStanMCMC"
    )
)


#' @rdname generateQuantities
#' @typed generator: QuantityGenerator
#'   object that specifies which subjects and time points
#'   to calculate the quantities at
#' @typed type: character
#'   type of quantities to be generated, must be either "survival" or
#'   "longitudinal".
#' @export
generateQuantities.JointModelSamples <- function(object, generator, type, ...) {
    data <- as_stan_list(object@data) |>
        append(as_stan_list(object@model@parameters)) |>
        append(as_stan_list(
            generator,
            data = object@data,
            model = object@model
        ))

    stanobj <- as.StanModule(object, generator = generator, type = type)
    model <- compileStanModel(stanobj)

    devnull <- utils::capture.output(
        results <- model$generate_quantities(
            data = data,
            fitted_params = object@results
        )
    )
    return(results)
}


#' `JointModelSamples` -> `StanModule`
#'
#' Converts a `JointModelSamples` object into a `StanModule` object ensuring
#' that the resulting `StanModule` object is able to generate post sampling
#' quantities.
#'
#' @inheritParams generateQuantities
#' @export
as.StanModule.JointModelSamples <- function(object, generator, type, ...) {
    assert_that(
        is(generator, "QuantityGenerator"),
        length(type) == 1,
        type %in% c("survival", "longitudinal")
    )

    quant_stanobj <- read_stan("base/quantities.stan") |>
        decorated_render(
            include_gq_longitudinal_idv = (type == "longitudinal") &
                is(generator, "QuantityGeneratorSubject"),
            include_gq_longitudinal_pop = (type == "longitudinal") &
                is(generator, "QuantityGeneratorPopulation"),
            include_gq_survival_idv = (type == "survival") &
                is(generator, "QuantityGeneratorSubject"),
            include_gq_survival_pred = (type == "survival") &
                is(generator, "QuantityGeneratorPrediction")
        ) |>
        StanModule()

    stanobj <- Reduce(
        merge,
        list(
            as.StanModule(object@model),
            enableGQ(object@model),
            quant_stanobj
        )
    )
    stanobj
}


#' `JointModelSamples` -> Printable `Character`
#'
#' Converts [`JointModelSamples`] object into a printable string.
#'
#' @typed object: JointModelSamples
#'   samples as drawn from a [`JointModel`].
#' @family JointModelSamples
#' @typed indent: numeric
#'   how much white space to prefix the print string with.
#' @keywords internal
#' @export
as_print_string.JointModelSamples <- function(object, indent = 1, ...) {
    sizes <- vapply(
        cmdstanr::as.CmdStanMCMC(object)$metadata()[["stan_variable_sizes"]],
        \(x) {
            if (length(x) == 1 && x == 1) {
                return("")
            }
            paste0("[", paste(x, collapse = ", "), "]")
        },
        character(1)
    )
    variable_string <- paste0(
        "        ",
        cmdstanr::as.CmdStanMCMC(object)$metadata()[["stan_variables"]],
        sizes
    )
    template <- c(
        "JointModelSamples Object with:",
        "",
        "    # of samples per chain = %d",
        "    # of chains            = %d",
        "",
        "    Variables:",
        variable_string[order(variable_string)]
    )
    pad <- rep(" ", indent) |> paste(collapse = "")
    template_padded <- paste(pad, template)
    sprintf(
        paste(template_padded, collapse = "\n"),
        cmdstanr::as.CmdStanMCMC(object)$metadata()$iter_sampling,
        cmdstanr::as.CmdStanMCMC(object)$num_chains()
    )
}

#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "JointModelSamples",
    definition = function(object) {
        string <- as_print_string(object)
        cat("\n", string, "\n\n")
    }
)


#' @rdname as.CmdStanMCMC
as.CmdStanMCMC.JointModelSamples <- function(object, ...) {
    return(object@results)
}


#' Save a `JointModelSamples` object to a file.
#'
#' This function is just a wrapper around `saveRDS` that saves the object to a file
#' ensuring that all of the Stan samples are correctly stored. Note that as
#' `cmdstanr` objects store their samples as a csv file the samples may be lost
#' if you call `saveRDS` directly on the object.
#'
#' @typed object: JointModelSamples
#'   the object to save.
#' @typed file: character
#'   the file to save the object to.
#' @typed ...: ANY
#'   additional arguments to [`saveRDS`].
#'
#' @family saveObject
#'
#' @export
saveObject.JointModelSamples <- function(object, file, ...) {
    object@results$draws()
    try(object@results$sampler_diagnostics(), silent = TRUE)
    try(object@results$init(), silent = TRUE)
    try(object@results$profiles(), silent = TRUE)
    saveRDS(object, file, ...)
}

#' @include LongitudinalModel.R
#' @include Link.R
NULL

# LongitudinalRandomSlope-class ----

#' `LongitudinalRandomSlope`
#'
#' This class extends the general [`LongitudinalModel`] class for using the
#' random slope linear model for the longitudinal outcome.
#'
#' @section Available Links:
#' - [`linkDSLD()`]
#' - [`linkIdentity()`]
#' @exportClass LongitudinalRandomSlope
.LongitudinalRandomSlope <- setClass(
    Class = "LongitudinalRandomSlope",
    contains = "LongitudinalModel"
)


# LongitudinalRandomSlope-constructors ----

#' @rdname LongitudinalRandomSlope-class
#'
#' @typed intercept: Prior
#'   for the `intercept`.
#' @typed slope_mu: Prior
#'   for the population slope `slope_mu` (one per arm).
#' @typed slope_sigma: Prior
#'   for the random slope standard deviation `slope_sigma` (one per arm).
#' @typed sigma: Prior
#'   for the variance of the longitudinal values `sigma`.
#'
#' @export
LongitudinalRandomSlope <- function(
    intercept = prior_normal(30, 10),
    slope_mu = prior_normal(1, 3),
    slope_sigma = prior_lognormal(0, 1.5),
    sigma = prior_lognormal(0, 1.5)
) {
    stan <- StanModule(
        x = "lm-random-slope/model.stan"
    )

    # Apply constriants
    sigma <- set_limits(sigma, lower = 0)
    slope_sigma <- set_limits(slope_sigma, lower = 0)

    .LongitudinalRandomSlope(
        LongitudinalModel(
            name = "Random Slope",
            stan = stan,
            parameters = ParameterList(
                Parameter(
                    name = "lm_rs_intercept",
                    prior = intercept,
                    size = "n_studies"
                ),
                Parameter(
                    name = "lm_rs_slope_mu",
                    prior = slope_mu,
                    size = "n_arms"
                ),
                Parameter(
                    name = "lm_rs_slope_sigma",
                    prior = slope_sigma,
                    size = "n_arms"
                ),
                Parameter(name = "lm_rs_sigma", prior = sigma, size = 1),
                Parameter(
                    name = "lm_rs_ind_rnd_slope",
                    prior = prior_init_only(prior_normal(
                        median(slope_mu),
                        median(slope_sigma)
                    )),
                    size = "n_subjects"
                )
            )
        )
    )
}


#' @export
enableGQ.LongitudinalRandomSlope <- function(object, ...) {
    StanModule("lm-random-slope/quantities.stan")
}

#' @export
enableLink.LongitudinalRandomSlope <- function(object, ...) {
    object@stan <- merge(
        object@stan,
        StanModule("lm-random-slope/link.stan")
    )
    object
}


#' @export
linkDSLD.LongitudinalRandomSlope <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    LinkComponent(
        key = "link_dsld",
        stan = StanModule("lm-random-slope/link_dsld.stan"),
        prior = prior
    )
}

#' @export
linkIdentity.LongitudinalRandomSlope <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    LinkComponent(
        key = "link_identity",
        stan = StanModule("lm-random-slope/link_identity.stan"),
        prior = prior
    )
}

#' @export
linkGrowth.LongitudinalRandomSlope <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    LinkComponent(
        key = "link_growth",
        stan = StanModule("lm-random-slope/link_growth.stan"),
        prior = prior
    )
}

#' @rdname getPredictionNames
#' @export
getPredictionNames.LongitudinalRandomSlope <- function(object, ...) {
    c("intercept", "slope")
}


#' @rdname getRandomEffectsNames
#' @export
getRandomEffectsNames.LongitudinalRandomSlope <- function(object, ...) {
    c("slope" = "lm_rs_ind_rnd_slope")
}

#' Re-used documentation for `DataSubject`
#'
#' @typed object: DataSubject
#'   subject-level data.
#' @typed x: DataSubject
#'   subject-level data.
#' @param ... Not Used.
#'
#' @name DataSubject-Shared
#' @keywords internal
NULL


#' Subject Data Object and Constructor Function
#'
#' The [`DataSubject`] class handles the processing of the subject data for
#' fitting a [`JointModel`].
#'
#' @slot data (`data.frame`)\cr the subject-level data.
#' @slot subject (`character`)\cr the name of the variable containing the subject identifier.
#' @slot arm (`character`)\cr the name of the variable containing the arm identifier.
#' @slot study (`character`)\cr the name of the variable containing the study identifier.
#'
#' @family DataObjects
#' @family DataSubject
#' @exportClass DataSubject
#' @export DataSubject
.DataSubject <- setClass(
    Class = "DataSubject",
    representation = list(
        data = "data.frame",
        subject = "character",
        arm = "character",
        study = "character"
    )
)


#' @typed data: data.frame
#'   the subject-level data.
#' @typed subject: character
#'   the name of the variable containing the subject identifier.
#' @typed arm: character
#'   the name of the variable containing the arm identifier.
#' @typed study: character
#'   the name of the variable containing the study identifier.
#' @rdname DataSubject-class
#' @export
DataSubject <- function(data, subject, arm, study) {
    vars <- c(subject, arm, study)
    vars_frm_chr <- paste0("~ ", paste(vars, collapse = " + "))
    .DataSubject(
        data = remove_missing_rows(data, stats::as.formula(vars_frm_chr)),
        subject = subject,
        arm = arm,
        study = study
    )
}

setValidity(
    "DataSubject",
    method = function(object) {
        if (length(object@subject) != 1) {
            return("`subject` must be a length 1 character")
        }
        if (length(object@arm) != 1) {
            return("`arm` must be a length 1 character")
        }
        if (length(object@study) != 1) {
            return("`study` must be a length 1 character")
        }
        if (nrow(object@data) == 0) {
            return("`data` should not have 0 rows")
        }
        sbj <- object@data[[object@subject]]
        if (!(is(sbj, "character") | is(sbj, "factor"))) {
            return("`data[[subject]]` should be of type character or factor")
        }
    }
)


#' @inheritParams DataSubject-Shared
#' @inherit extractVariableNames description title
#'
#' @returns
#' A list with the following named elements:
#' - `subject` (`character`)\cr the name of the variable containing the subject identifier.
#' - `arm` (`character`)\cr the name of the variable containing the arm identifier.
#' - `study` (`character`) \cr the name of the variable containing the study identifier.
#' @family DataSubject
#' @family extractVariableNames
#' @export
#' @keywords internal
extractVariableNames.DataSubject <- function(object) {
    list(
        subject = object@subject,
        arm = object@arm,
        study = object@study
    )
}


#' @rdname as_stan_list.DataObject
#' @family DataSubject
#' @export
as_stan_list.DataSubject <- function(object, ...) {
    df <- as.data.frame(harmonise(object))
    vars <- extractVariableNames(object)

    unique_arm_study_combos <- unique(
        data.frame(
            arm = as.numeric(df[[vars$arm]]),
            study = as.numeric(df[[vars$study]])
        )
    )

    list(
        n_subjects = nrow(df),
        n_studies = length(unique(df[[vars$study]])),
        n_arms = length(unique(df[[vars$arm]])),
        subject_study_index = as.numeric(df[[vars$study]]),
        subject_arm_index = as.numeric(df[[vars$arm]]),
        subject_to_index = stats::setNames(
            seq_len(nlevels(df[[vars$subject]])),
            levels(df[[vars$subject]])
        ),
        arm_to_index = stats::setNames(
            seq_len(nlevels(df[[vars$arm]])),
            levels(df[[vars$arm]])
        ),
        study_to_index = stats::setNames(
            seq_len(nlevels(df[[vars$study]])),
            levels(df[[vars$study]])
        ),
        pop_arm_index = unique_arm_study_combos$arm,
        pop_study_index = unique_arm_study_combos$study
    )
}

#' @rdname as_stan_list.DataObject
#' @export
as.list.DataSubject <- function(x, ...) {
    as_stan_list(x, ...)
}


#' `DataSubject` -> `data.frame`
#'
#' @inheritParams DataSubject-Shared
#'
#' @description
#' Converts a [`DataSubject`] object into a `data.frame`.
#' The subject variable is cast to factor.
#' @family DataSubject
#' @export
as.data.frame.DataSubject <- function(x, ...) {
    x <- x@data
    rownames(x) <- NULL
    x
}


#' @rdname harmonise
#' @exportS3Method NULL
harmonise.DataSubject <- function(object, ...) {
    data <- as.data.frame(object)
    vars <- extractVariableNames(object)
    assert_that(
        vars$subject %in% names(data),
        vars$arm %in% names(data),
        vars$study %in% names(data)
    )
    assert_character(
        as.character(data[[vars$subject]]),
        any.missing = FALSE,
        unique = TRUE
    )
    data[[vars$subject]] <- factor(data[[vars$subject]])
    data[[vars$arm]] <- factor(data[[vars$arm]])
    data[[vars$study]] <- factor(data[[vars$study]])
    data <- data[order(data[[vars$subject]]), ]
    DataSubject(
        data = data,
        subject = object@subject,
        arm = object@arm,
        study = object@study
    )
}

#' `DataSubject` -> Printable `Character`
#'
#' Converts [`DataSubject`] object into a printable string.
#' @inheritParams DataSubject-Shared
#' @family DataSubject
#' @keywords internal
#' @typed indent: numeric
#'   how much white space to prefix the print string with.
#' @export
as_print_string.DataSubject <- function(object, indent = 1, ...) {
    template <- c(
        "Subject-Data Object:",
        "    # of Subjects = %d",
        "    # of Studies  = %d",
        "    # of Arms     = %d"
    )
    pad <- rep(" ", indent) |> paste(collapse = "")
    template_padded <- paste(pad, template)
    vars <- extractVariableNames(object)
    sprintf(
        paste(template_padded, collapse = "\n"),
        nrow(object@data),
        length(unique(object@data[[vars$study]])),
        length(unique(object@data[[vars$arm]]))
    )
}

#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "DataSubject",
    definition = function(object) {
        string <- as_print_string(object)
        cat("\n", string, "\n\n")
    }
)

#' @include StanModule.R
#' @include generics.R
#' @include ParameterList.R
#' @include DataJoint.R
#' @include DataSurvival.R
#' @include DataLongitudinal.R
#' @include LongitudinalModel.R
#' @include SurvivalModel.R
#' @include Link.R
#' @include constants.R
NULL


#' Re-used documentation for `JointModel-Shared`
#'
#' @typed object: JointModel
#'   Joint model specification.
#' @typed x: JointModel
#'   Joint model specification.
#' @param ... Not Used.
#'
#' @name JointModel-Shared
#' @keywords internal
NULL

setClassUnion("LongitudinalModel_OR_NULL", c("LongitudinalModel", "NULL"))
setClassUnion("SurvivalModel_OR_NULL", c("SurvivalModel", "NULL"))

# JointModel-class ----

#' Joint Model Object and Constructor Function
#'
#' @slot longitudinal ([`LongitudinalModel`] or `NULL`)\cr the longitudinal model.
#' @slot survival ([`SurvivalModel`] or `NULL`)\cr the survival model.
#' @slot link (`Link`)\cr the link.
#' @slot parameters (`ParameterList`)\cr the parameter specification.
#'
#' @family JointModel
#' @export JointModel
#' @exportClass JointModel
.JointModel <- setClass(
    Class = "JointModel",
    slots = list(
        longitudinal = "LongitudinalModel_OR_NULL",
        survival = "SurvivalModel_OR_NULL",
        link = "Link",
        parameters = "ParameterList"
    )
)

#' @typed longitudinal: "`LongitudinalModel` or `NULL`"
#'   the longitudinal model.
#' @typed survival: "`SurvivalModel` or `NULL`"
#'   the survival model.
#' @typed link: Link
#'   the link.
#' @rdname JointModel-class
JointModel <- function(
    longitudinal = NULL,
    survival = NULL,
    link = Link()
) {
    link <- resolvePromise(Link(link), longitudinal)

    if (length(link) > 0) {
        longitudinal <- enableLink(longitudinal)
    }

    parameters <- Reduce(
        merge,
        list(
            getParameters(longitudinal),
            getParameters(survival),
            getParameters(link)
        )
    )

    .JointModel(
        longitudinal = longitudinal,
        survival = survival,
        link = link,
        parameters = parameters
    )
}


#' @export
enableGQ.JointModel <- function(object, ...) {
    merge(
        enableGQ(object@survival),
        enableGQ(object@longitudinal)
    )
}


#' `JointModel` -> `StanModule`
#'
#' Converts a [`JointModel`] object to a [`StanModule`] object
#'
#' @inheritParams JointModel-Shared
#' @family JointModel
#' @family as.StanModule
#' @export
as.StanModule.JointModel <- function(object, ...) {
    base_model <- read_stan("base/base.stan")

    stan_full <- decorated_render(
        .x = base_model,
        longitudinal = add_missing_stan_blocks(as.list(object@longitudinal)),
        survival = add_missing_stan_blocks(as.list(object@survival)),
        link = add_missing_stan_blocks(as.list(object@link)),
        priors = add_missing_stan_blocks(as.list(object@parameters)),
        has_os_submodel = !is.null(object@survival),
        has_long_submodel = !is.null(object@longitudinal)
    )
    # Unresolved Jinja code within the longitudinal / Survival / Link
    # models won't be resolved by the above call to `decorated_render`.
    # Instead they it will just be inserted into the template asis. Thus
    # we run `decorated_render` again to resolve any lingering Jinja code
    # Main example being models that don't have any Jinja code but still
    # use the `decorated_render` constants `machine_double_eps`.
    stan_full <- decorated_render(.x = stan_full)

    merge(
        StanModule("base/functions.stan"),
        StanModule(stan_full)
    )
}


#' `JointModel` -> `character`
#'
#' Renders a [`JointModel`] object to a stan program
#'
#' @inheritParams JointModel-Shared
#' @family JointModel
#' @export
as.character.JointModel <- function(x, ...) {
    as.character(as.StanModule(x))
}


# write_stan-JointModel ----

#' @rdname write_stan
#' @export
write_stan.JointModel <- function(object, destination, ...) {
    if (is_connection(destination)) {
        return(writeLines(as.character(object), con = destination))
    }
    fi <- file(destination, open = "w")
    writeLines(as.character(object), con = fi)
    close(fi)
}


# compileStanModel-JointModel ----

#' @rdname compileStanModel
#' @export
compileStanModel.JointModel <- function(object) {
    object |>
        as.StanModule() |>
        compileStanModel() |>
        invisible()
}


# sampleStanModel-JointModel ----

#' @rdname sampleStanModel
#'
#' @typed data: "`DataJoint` or `list`"
#'   input data.
#' @export
sampleStanModel.JointModel <- function(object, data, ...) {
    assert_class(data, "DataJoint")

    if (!is.null(object@survival)) {
        assert_that(
            !is.null(data@survival),
            msg = "`DataSurvival` can't be missing if a `SurvivalModel` has been specified"
        )
    }
    if (!is.null(object@longitudinal)) {
        assert_that(
            !is.null(data@longitudinal),
            msg = "`DataLongitudinal` can't be missing if a `LongitudinalModel` has been specified"
        )
    }

    args <- list(...)

    args[["data"]] <- append(
        as_stan_list(data),
        as_stan_list(object@parameters)
    )

    args[["chains"]] <- if ("chains" %in% names(args)) {
        args[["chains"]]
    } else {
        # Magic constant from R/constants.R
        CMDSTAN_DEFAULT_CHAINS
    }

    initial_values <- if ("init" %in% names(args)) {
        args[["init"]]
    } else {
        initialValues(object, n_chains = args[["chains"]])
    }

    args[["init"]] <- ensure_initial_values(
        initial_values,
        args[["data"]],
        object@parameters
    )

    model <- compileStanModel(object)

    results <- do.call(
        model$sample,
        args
    )

    .JointModelSamples(
        model = object,
        data = data,
        results = results
    )
}


#' Ensure that initial values are correctly specified
#'
#' @typed initial_values: list
#'   A list of lists containing the initial values
#'   must be 1 list per desired chain. All elements should have identical names
#' @typed data: list
#'   specifies the size to expand each of our initial values to be.
#'   That is elements of size 1 in `initial_values` will be expanded to be the same
#'   size as the corresponding element in `data` by broadcasting the value.
#' @typed parameters: ParameterList
#'   the parameters object
#'
#' @details
#' This function is mostly a thin wrapper around `expand_initial_values` to
#' enable easier unit testing.
#'
#' @keywords internal
ensure_initial_values <- function(initial_values, data, parameters) {
    if (is.function(initial_values)) {
        return(initial_values)
    }

    assert_class(data, "list")
    assert_class(parameters, "ParameterList")
    assert_class(initial_values, "list")

    values_sizes <- size(parameters)
    values_sizes_complete <- replace_with_lookup(
        values_sizes,
        data
    )
    lapply(
        initial_values,
        expand_initial_values,
        sizes = values_sizes_complete
    )
}


#' @rdname initialValues
#' @export
initialValues.JointModel <- function(object, n_chains, ...) {
    initialValues(object@parameters, n_chains)
}


pad_with_white_space <- function(x, pad = 4) {
    padding <- paste0(rep(" ", each = pad), collapse = "")
    x_sep <- x |>
        strsplit(split = "\n") |>
        unlist()
    x_padded <- paste(padding, x_sep) |>
        paste(collapse = "\n")
    return(x_padded)
}


#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "JointModel",
    definition = function(object) {
        survival_string <- if (is.null(object@survival)) {
            "\n     Not Specified\n"
        } else {
            as_print_string(object@survival) |> pad_with_white_space()
        }

        longitudinal_string <- if (is.null(object@longitudinal)) {
            "\n     Not Specified\n"
        } else {
            as_print_string(object@longitudinal) |> pad_with_white_space()
        }

        link_string <- as_print_string(object@link) |> pad_with_white_space()

        string <- "\nA Joint Model with:\n\n  Survival:%s\n  Longitudinal:%s\n  Link:%s\n"
        cat(sprintf(
            string,
            survival_string,
            longitudinal_string,
            link_string
        ))
    }
)


#' @rdname getRandomEffectsNames
#' @export
getRandomEffectsNames.JointModel <- function(object, ...) {
    if (is.null(object@longitudinal)) {
        return(NULL)
    }
    getRandomEffectsNames(object@longitudinal)
}

#' @include StanModel.R
NULL

# SurvivalModel-class ----

#' `SurvivalModel`
#'
#' This class extends the general [`StanModel`] class to comprise the survival
#' model specification.
#'
#' @exportClass SurvivalModel
.SurvivalModel <- setClass(
    Class = "SurvivalModel",
    contains = "StanModel"
)

# SurvivalModel-constructors ----

#' @rdname SurvivalModel-class
#'
#' @inheritParams stanmodel_arguments
#'
#' @export
SurvivalModel <- function(
    stan = StanModule(),
    parameters = ParameterList(),
    name = "<Unnamed>",
    ...
) {
    base_stan <- read_stan("base/survival.stan")
    stan_full <- decorated_render(
        .x = base_stan,
        stan = add_missing_stan_blocks(as.list(stan))
    )
    .SurvivalModel(
        StanModel(
            name = name,
            stan = StanModule(stan_full),
            parameters = parameters,
            ...
        )
    )
}

#' @export
as_print_string.SurvivalModel <- function(object, ...) {
    string <- sprintf(
        "\n%s Survival Model with parameters:\n%s\n\n",
        object@name,
        paste("   ", as_print_string(object@parameters)) |>
            paste(collapse = "\n")
    )
    return(string)
}

#' @include generics.R
#' @include utilities.R
NULL

#' Re-used documentation for `DataLongitudinal`
#'
#' @typed object: DataLongitudinal
#'   Longitudinal Data.
#' @typed x: DataLongitudinal
#'   Longitudinal Data.
#' @param ... Not Used.
#'
#' @name DataLongitudinal-Shared
#' @keywords internal
NULL


# DataLongitudinal-class ----

#' Longitudinal Data Object and Constructor Function
#'
#' The [`DataLongitudinal`] class handles the processing of the longitudinal data for fitting a Joint Model.
#'
#'
#' @slot data (`data.frame`)\cr See Arguments for details; Note that
#'   observations that contain missing values in the required variables are removed.
#' @slot formula (`formula`)\cr See Arguments for details
#' @slot threshold (`numeric`)\cr See Arguments for details
#'
#' @family DataObjects
#' @family DataLongitudinal
#' @export DataLongitudinal
#' @exportClass DataLongitudinal
.DataLongitudinal <- setClass(
    Class = "DataLongitudinal",
    representation = list(
        data = "data.frame",
        formula = "formula",
        threshold = "numeric_or_NULL"
    )
)


#' @typed data: data.frame
#'   containing the observed longitudinal data.
#' @typed formula: formula
#'   of the form `outcome ~ time`, and cannot contain any additional covariates.
#' @typed threshold: numeric
#'   cut-off value to be used to declare an observation as censored
#'   (below detection limit).
#' @rdname DataLongitudinal-class
DataLongitudinal <- function(data, formula, threshold = NULL) {
    .DataLongitudinal(
        data = remove_missing_rows(data, formula),
        formula = formula,
        threshold = threshold
    )
}

setValidity(
    "DataLongitudinal",
    function(object) {
        if (!length(object@formula) == 3) {
            return("`formula` should be a 2 sided formula")
        }
        if (!length(object@formula[[3]]) == 1) {
            return("the RHS of `formula` should only have 1 value")
        }
        if (!length(object@threshold) <= 1) {
            return("`threshold` must be of length 1 or `NULL`")
        }
        vars <- extractVariableNames(object)
        vars$threshold <- NULL
        vars$frm <- NULL
        for (i in unlist(vars)) {
            if (!i %in% names(object@data)) {
                return(sprintf("Variable `%s` is not in data", i))
            }
        }
        return(TRUE)
    }
)


#' @rdname harmonise
#' @exportS3Method NULL
harmonise.DataLongitudinal <- function(object, subject_var, subject_ord, ...) {
    data <- as.data.frame(object)
    vars <- extractVariableNames(object)
    assert_string(subject_var, na.ok = FALSE)
    assert_character(subject_ord, any.missing = FALSE)
    assert_that(
        subject_var %in% names(data),
        msg = sprintf(
            "Subject variable `%s` not found in `longitudinal`",
            subject_var
        )
    )
    assert_that(
        all(data[[subject_var]] %in% subject_ord),
        msg = "There are subjects in `longitudinal` that are not present in `subjects`"
    )
    assert_that(
        all(subject_ord %in% data[[subject_var]]),
        msg = "There are subjects in `subjects` that are not present in `longitudinal`"
    )
    data[[subject_var]] <- factor(
        as.character(data[[subject_var]]),
        levels = subject_ord
    )
    data_re_ord <- order(
        data[[subject_var]],
        data[[vars$time]],
        data[[vars$outcome]]
    )
    data_ord <- data[data_re_ord, ]
    DataLongitudinal(
        data = data_ord,
        formula = object@formula,
        threshold = object@threshold
    )
}


#' `DataLongitudinal` -> `data.frame`
#'
#' @inheritParams DataLongitudinal-Shared
#'
#' @description
#' Converts a [`DataLongitudinal`] object into a `data.frame`.
#' The subject variable is cast to factor.
#' @family DataLongitudinal
#' @export
as.data.frame.DataLongitudinal <- function(x, ...) {
    x <- x@data
    rownames(x) <- NULL
    x
}


#' @inheritParams DataLongitudinal-Shared
#' @inherit extractVariableNames description title
#'
#' @returns
#' A list with the following named elements:
#' - `subject` (`character`)\cr The name of the variable containing the subject identifier
#' - `frm` (`formula`)\cr of the form `outcome ~ time`
#' - `time` (`character`)\cr The name of the variable containing the outcome time
#' - `outcome` (`character`)\cr The name of the variable containing the outcome values
#' - `threshold` (`numeric`)\cr cut-off value to be used to declare an observation as censored
#'   (below detection limit).
#' @family DataLongitudinal
#' @family extractVariableNames
#' @exportS3Method NULL
extractVariableNames.DataLongitudinal <- function(object) {
    list(
        frm = object@formula,
        time = as.character(object@formula[[3]]),
        outcome = as.character(object@formula[[2]]),
        threshold = object@threshold
    )
}


#' @rdname as_stan_list.DataObject
#' @family DataLongitudinal
#' @export
as_stan_list.DataLongitudinal <- function(object, subject_var, ...) {
    df <- as.data.frame(object)
    vars <- extractVariableNames(object)

    assert_factor(df[[subject_var]])

    mat_sld_index <- stats::model.matrix(
        stats::as.formula(paste("~ -1 + ", subject_var)),
        data = df
    ) |>
        t()

    adj_threshold <- if (is.null(vars$threshold)) {
        -999999
    } else {
        vars$threshold
    }

    index_obs <- which(df[[vars$outcome]] >= adj_threshold)
    index_cen <- which(df[[vars$outcome]] < adj_threshold)

    sparse_mat_inds_all_y <- rstan::extract_sparse_parts(mat_sld_index)
    sparse_mat_inds_obs_y <- rstan::extract_sparse_parts(
        mat_sld_index[, index_obs]
    )
    sparse_mat_inds_cens_y <- rstan::extract_sparse_parts(
        mat_sld_index[, index_cen]
    )

    model_data <- list(
        n_tumour_all = nrow(df),

        # Number of individuals and tumour assessments.
        n_tumour_obs = length(index_obs),
        n_tumour_cens = length(index_cen),

        # Index vectors
        subject_tumour_index = as.numeric(df[[subject_var]]),
        subject_tumour_index_obs = index_obs,
        subject_tumour_index_cens = index_cen,

        tumour_value = df[[vars$outcome]],
        tumour_time = df[[vars$time]],
        tumour_value_lloq = adj_threshold,

        # Sparse matrix parameters
        # Matrix of individuals x observed tumour assessments.
        n_mat_inds_obs_y = c(
            length(sparse_mat_inds_obs_y$w),
            length(sparse_mat_inds_obs_y$v),
            length(sparse_mat_inds_obs_y$u)
        ),
        w_mat_inds_obs_y = sparse_mat_inds_obs_y$w,
        v_mat_inds_obs_y = sparse_mat_inds_obs_y$v,
        u_mat_inds_obs_y = sparse_mat_inds_obs_y$u,

        # Matrix of individuals x censored tumour assessments.
        n_mat_inds_cens_y = c(
            length(sparse_mat_inds_cens_y$w),
            length(sparse_mat_inds_cens_y$v),
            length(sparse_mat_inds_cens_y$u)
        ),
        w_mat_inds_cens_y = sparse_mat_inds_cens_y$w,
        v_mat_inds_cens_y = sparse_mat_inds_cens_y$v,
        u_mat_inds_cens_y = sparse_mat_inds_cens_y$u,

        # Matrix of all individuals tumour assessments
        n_mat_inds_all_y = c(
            length(sparse_mat_inds_all_y$w),
            length(sparse_mat_inds_all_y$v),
            length(sparse_mat_inds_all_y$u)
        ),
        w_mat_inds_all_y = sparse_mat_inds_all_y$w,
        v_mat_inds_all_y = sparse_mat_inds_all_y$v,
        u_mat_inds_all_y = sparse_mat_inds_all_y$u
    )

    return(model_data)
}

#' @rdname as_stan_list.DataObject
#' @export
as.list.DataLongitudinal <- function(x, ...) {
    as_stan_list(x, ...)
}


#' `DataLongitudinal` -> Printable `Character`
#'
#' Converts [`DataLongitudinal`] object into a printable string.
#' @inheritParams DataLongitudinal-Shared
#' @family DataLongitudinal
#' @typed indent: numeric
#'   how much white space to prefix the print string with.
#' @keywords internal
#' @export
as_print_string.DataLongitudinal <- function(object, indent = 1, ...) {
    template <- c(
        "Longitudinal-Data Object:",
        "    # of Rows     = %d",
        "    # of Columns  = %d",
        "    # of Cen-Obvs = %d",
        "    Formula       = %s"
    )
    pad <- rep(" ", indent) |> paste(collapse = "")
    template_padded <- paste(pad, template)
    vars <- extractVariableNames(object)
    sprintf(
        paste(template_padded, collapse = "\n"),
        nrow(object@data),
        ncol(object@data),
        sum(object@data[[vars$outcome]] < vars$threshold),
        Reduce(paste, deparse(vars$frm))
    )
}

#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "DataLongitudinal",
    definition = function(object) {
        string <- as_print_string(object)
        cat("\n", string, "\n\n")
    }
)

#' @include LongitudinalModel.R
#' @include StanModule.R
#' @include generics.R
#' @include ParameterList.R
#' @include Parameter.R
#' @include Link.R
NULL


#' `LongitudinalClaretBruno`
#'
#' This class extends the general [`LongitudinalModel`] class for using the
#' Claret-Bruno model for the longitudinal outcome.
#'
#' @section Available Links:
#' - [`linkDSLD()`]
#' - [`linkTTG()`]
#' - [`linkIdentity()`]
#' - [`linkGrowth()`]
#' @exportClass LongitudinalClaretBruno
.LongitudinalClaretBruno <- setClass(
    Class = "LongitudinalClaretBruno",
    contains = "LongitudinalModel"
)


#' @rdname LongitudinalClaretBruno-class
#'
#' @typed mu_b: Prior
#'   for the mean population baseline sld value.
#' @typed mu_g: Prior
#'   for the mean population growth rate.
#' @typed mu_c: Prior
#'   for the mean population resistance rate.
#' @typed mu_p: Prior
#'   for the mean population growth inhibition
#'
#' @typed omega_b: Prior
#'   for the population standard deviation for the baseline sld value.
#' @typed omega_g: Prior
#'   for the population standard deviation for the growth rate.
#' @typed omega_c: Prior
#'   for the population standard deviation for the resistance rate.
#' @typed omega_p: Prior
#'   for the population standard deviation for the growth inhibition.
#'
#' @typed sigma: Prior
#'   for the variance of the longitudinal values.
#'
#' @typed centred: logical
#'   whether to use the centred parameterization.
#' @typed scaled_variance: logical
#'   whether the variance should be scaled by the expected value
#'   (see the "Statistical Specifications" vignette for more details)
#'
#' @export
LongitudinalClaretBruno <- function(
    mu_b = prior_normal(log(60), 0.5),
    mu_g = prior_normal(log(1), 0.5),
    mu_c = prior_normal(log(0.4), 0.5),
    mu_p = prior_normal(log(2), 0.5),

    omega_b = prior_lognormal(log(0.2), 0.5),
    omega_g = prior_lognormal(log(0.2), 0.5),
    omega_c = prior_lognormal(log(0.2), 0.5),
    omega_p = prior_lognormal(log(0.2), 0.5),

    sigma = prior_lognormal(log(0.1), 0.5),

    scaled_variance = TRUE,
    centred = FALSE
) {
    sf_model <- StanModule(decorated_render(
        .x = read_stan("lm-claret-bruno/model.stan"),
        scaled_variance = scaled_variance,
        centred = centred
    ))

    # Apply constraints
    omega_b <- set_limits(omega_b, lower = 0)
    omega_g <- set_limits(omega_g, lower = 0)
    omega_c <- set_limits(omega_c, lower = 0)
    omega_p <- set_limits(omega_p, lower = 0)
    sigma <- set_limits(sigma, lower = 0)

    parameters <- list(
        Parameter(name = "lm_clbr_mu_b", prior = mu_b, size = "n_studies"),
        Parameter(name = "lm_clbr_mu_g", prior = mu_g, size = "n_arms"),
        Parameter(name = "lm_clbr_mu_c", prior = mu_c, size = "n_arms"),
        Parameter(name = "lm_clbr_mu_p", prior = mu_p, size = "n_arms"),

        Parameter(
            name = "lm_clbr_omega_b",
            prior = omega_b,
            size = "n_studies"
        ),
        Parameter(name = "lm_clbr_omega_g", prior = omega_g, size = "n_arms"),
        Parameter(name = "lm_clbr_omega_c", prior = omega_c, size = "n_arms"),
        Parameter(name = "lm_clbr_omega_p", prior = omega_p, size = "n_arms"),

        Parameter(name = "lm_clbr_sigma", prior = sigma, size = 1)
    )

    assert_flag(centred)
    parameters_extra <- if (centred) {
        list(
            Parameter(
                name = "lm_clbr_ind_b",
                prior = prior_init_only(prior_lognormal(
                    median(mu_b),
                    median(omega_b)
                )),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_clbr_ind_g",
                prior = prior_init_only(prior_lognormal(
                    median(mu_g),
                    median(omega_g)
                )),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_clbr_ind_c",
                prior = prior_init_only(prior_lognormal(
                    median(mu_c),
                    median(omega_c)
                )),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_clbr_ind_p",
                prior = prior_init_only(prior_lognormal(
                    median(mu_p),
                    median(omega_p)
                )),
                size = "n_subjects"
            )
        )
    } else {
        list(
            Parameter(
                name = "lm_clbr_eta_b",
                prior = prior_std_normal(),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_clbr_eta_g",
                prior = prior_std_normal(),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_clbr_eta_c",
                prior = prior_std_normal(),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_clbr_eta_p",
                prior = prior_std_normal(),
                size = "n_subjects"
            )
        )
    }
    parameters <- append(parameters, parameters_extra)

    x <- LongitudinalModel(
        name = "Claret-Bruno",
        stan = merge(
            sf_model,
            StanModule("lm-claret-bruno/functions.stan")
        ),
        parameters = do.call(ParameterList, parameters)
    )
    .LongitudinalClaretBruno(x)
}


#' @export
enableLink.LongitudinalClaretBruno <- function(object, ...) {
    object@stan <- merge(
        object@stan,
        StanModule("lm-claret-bruno/link.stan")
    )
    object
}

#' @export
linkDSLD.LongitudinalClaretBruno <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    LinkComponent(
        key = "link_dsld",
        stan = StanModule("lm-claret-bruno/link_dsld.stan"),
        prior = prior
    )
}

#' @export
linkTTG.LongitudinalClaretBruno <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    LinkComponent(
        key = "link_ttg",
        stan = StanModule("lm-claret-bruno/link_ttg.stan"),
        prior = prior
    )
}

#' @export
linkIdentity.LongitudinalClaretBruno <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    LinkComponent(
        key = "link_identity",
        stan = StanModule("lm-claret-bruno/link_identity.stan"),
        prior = prior
    )
}

#' @export
linkGrowth.LongitudinalClaretBruno <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    LinkComponent(
        key = "link_growth",
        stan = StanModule("lm-claret-bruno/link_growth.stan"),
        prior = prior
    )
}

#' @rdname getPredictionNames
#' @export
getPredictionNames.LongitudinalClaretBruno <- function(object, ...) {
    c("b", "g", "c", "p")
}

#' @export
enableGQ.LongitudinalClaretBruno <- function(object, ...) {
    StanModule("lm-claret-bruno/quantities.stan")
}


#' @rdname getRandomEffectsNames
#' @export
getRandomEffectsNames.LongitudinalGSF <- function(object, ...) {
    c(
        "b" = "lm_clbr_ind_b",
        "g" = "lm_clbr_ind_g",
        "c" = "lm_clbr_ind_c",
        "p" = "lm_clbr_ind_p"
    )
}

#' @include Grid.R
#' @include generics.R
NULL


#' @rdname Grid-Dev
.GridEven <- setClass(
    "GridEven",
    contains = "Grid",
    slots = c(
        "subjects" = "character",
        "length.out" = "numeric"
    )
)


#' @rdname Grid-Functions
#' @export
GridEven <- function(subjects = NULL, length.out = 30) {
    .GridEven(
        subjects = subjects,
        length.out = length.out
    )
}


setValidity(
    "GridEven",
    function(object) {
        if (length(object@length.out) != 1 || all(object@length.out <= 0)) {
            return("The `length.out` argument must be a positive integer")
        }
    }
)


#' @rdname Quant-Dev
#' @export
as.QuantityGenerator.GridEven <- function(object, data, ...) {
    assert_class(data, "DataJoint")
    data_list <- as.list(data)
    subjects <- unlist(as.list(object, data = data), use.names = FALSE)
    assert_that(
        all(subjects %in% names(data_list$subject_to_index)),
        msg = "All subject names must be in the `DataSubject` object"
    )

    spec <- lapply(
        subjects,
        \(sub) {
            subject_index <- data_list$subject_to_index[[sub]]
            time_index <- data_list$subject_tumour_index == subject_index
            subject_times <- data_list$tumour_time[time_index]
            seq(
                min(subject_times),
                max(subject_times),
                length.out = object@length.out
            )
        }
    )
    names(spec) <- subjects

    as.QuantityGenerator(
        GridManual(spec),
        data = data
    )
}


#' @rdname Quant-Dev
#' @export
as.QuantityCollapser.GridEven <- function(object, data, ...) {
    generator <- as.QuantityGenerator(object, data)
    QuantityCollapser(
        times = generator@times,
        groups = generator@subjects,
        indexes = as.list(seq_along(generator@times))
    )
}


#' @export
as.list.GridEven <- function(x, data, ...) {
    subjects_to_list(x@subjects, data)
}

#' @include LongitudinalModel.R
#' @include StanModule.R
#' @include generics.R
#' @include ParameterList.R
#' @include Parameter.R
#' @include Link.R
NULL

# LongitudinalGSF-class ----

#' `LongitudinalGSF`
#'
#' This class extends the general [`LongitudinalModel`] class for using the
#' Generalized Stein-Fojo (GSF) model for the longitudinal outcome.
#'
#' @section Available Links:
#' - [`linkDSLD()`]
#' - [`linkTTG()`]
#' - [`linkIdentity()`]
#' - [`linkGrowth()`]
#' @exportClass LongitudinalGSF
.LongitudinalGSF <- setClass(
    Class = "LongitudinalGSF",
    contains = "LongitudinalModel"
)

# LongitudinalGSF-constructors ----

#' @rdname LongitudinalGSF-class
#'
#' @typed mu_bsld: Prior
#'   for the mean baseline value `mu_bsld`.
#' @typed mu_ks: Prior
#'   for the mean shrinkage rate `mu_ks`.
#' @typed mu_kg: Prior
#'   for the mean growth rate `mu_kg`.
#' @typed mu_phi: Prior
#'   for the mean proportion of cells affected by the treatment `mu_phi`.
#'
#' @typed omega_bsld: Prior
#'   for the baseline value standard deviation `omega_bsld`.
#' @typed omega_ks: Prior
#'   for the shrinkage rate standard deviation `omega_ks`.
#' @typed omega_kg: Prior
#'   for the growth rate standard deviation `omega_kg`.
#' @typed omega_phi: Prior
#'   for the standard deviation of the proportion of cells
#'   affected by the treatment `omega_phi`.
#'
#' @typed sigma: Prior
#'   for the variance of the longitudinal values `sigma`.
#'
#' @typed centred: logical
#'   whether to use the centred parameterization.
#' @typed scaled_variance: logical
#'   whether the variance should be scaled by the expected value
#'   (see the "Statistical Specifications" vignette for more details)
#'
#' @importFrom stats qlogis
#' @export
LongitudinalGSF <- function(
    mu_bsld = prior_normal(log(60), 1),
    mu_ks = prior_normal(log(0.5), 1),
    mu_kg = prior_normal(log(0.3), 1),
    mu_phi = prior_normal(qlogis(0.5), 1),

    omega_bsld = prior_lognormal(log(0.2), 1),
    omega_ks = prior_lognormal(log(0.2), 1),
    omega_kg = prior_lognormal(log(0.2), 1),
    omega_phi = prior_lognormal(log(0.2), 1),

    sigma = prior_lognormal(log(0.1), 1),

    scaled_variance = TRUE,
    centred = FALSE
) {
    gsf_model <- StanModule(decorated_render(
        .x = read_stan("lm-gsf/model.stan"),
        centred = centred,
        scaled_variance = scaled_variance
    ))

    # Apply constraints
    omega_bsld <- set_limits(omega_bsld, lower = 0)
    omega_ks <- set_limits(omega_ks, lower = 0)
    omega_kg <- set_limits(omega_kg, lower = 0)
    omega_phi <- set_limits(omega_phi, lower = 0)
    sigma <- set_limits(sigma, lower = 0)

    parameters <- list(
        Parameter(name = "lm_gsf_mu_bsld", prior = mu_bsld, size = "n_studies"),
        Parameter(name = "lm_gsf_mu_ks", prior = mu_ks, size = "n_arms"),
        Parameter(name = "lm_gsf_mu_kg", prior = mu_kg, size = "n_arms"),
        Parameter(name = "lm_gsf_mu_phi", prior = mu_phi, size = "n_arms"),

        Parameter(
            name = "lm_gsf_omega_bsld",
            prior = omega_bsld,
            size = "n_studies"
        ),
        Parameter(name = "lm_gsf_omega_ks", prior = omega_ks, size = "n_arms"),
        Parameter(name = "lm_gsf_omega_kg", prior = omega_kg, size = "n_arms"),
        Parameter(
            name = "lm_gsf_omega_phi",
            prior = omega_phi,
            size = "n_arms"
        ),

        Parameter(name = "lm_gsf_sigma", prior = sigma, size = 1)
    )

    assert_flag(centred)
    parameters_extra <- if (centred) {
        list(
            Parameter(
                name = "lm_gsf_psi_bsld",
                prior = prior_init_only(prior_lognormal(
                    median(mu_bsld),
                    median(omega_bsld)
                )),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_gsf_psi_ks",
                prior = prior_init_only(prior_lognormal(
                    median(mu_ks),
                    median(omega_ks)
                )),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_gsf_psi_kg",
                prior = prior_init_only(prior_lognormal(
                    median(mu_kg),
                    median(omega_kg)
                )),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_gsf_psi_phi_logit",
                prior = prior_init_only(prior_normal(
                    median(mu_phi),
                    median(omega_phi)
                )),
                size = "n_subjects"
            )
        )
    } else {
        list(
            Parameter(
                name = "lm_gsf_eta_tilde_bsld",
                prior = prior_std_normal(),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_gsf_eta_tilde_ks",
                prior = prior_std_normal(),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_gsf_eta_tilde_kg",
                prior = prior_std_normal(),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_gsf_eta_tilde_phi",
                prior = prior_std_normal(),
                size = "n_subjects"
            )
        )
    }
    parameters <- append(parameters, parameters_extra)

    x <- LongitudinalModel(
        name = "Generalized Stein-Fojo",
        stan = merge(
            gsf_model,
            StanModule("lm-gsf/functions.stan")
        ),
        parameters = do.call(ParameterList, parameters)
    )
    .LongitudinalGSF(x)
}


#' @export
enableGQ.LongitudinalGSF <- function(object, ...) {
    StanModule("lm-gsf/quantities.stan")
}


#' @export
enableLink.LongitudinalGSF <- function(object, ...) {
    object@stan <- merge(
        object@stan,
        StanModule("lm-gsf/link.stan")
    )
    object
}

#' @export
linkDSLD.LongitudinalGSF <- function(prior = prior_normal(0, 2), model, ...) {
    LinkComponent(
        key = "link_dsld",
        stan = StanModule("lm-gsf/link_dsld.stan"),
        prior = prior
    )
}

#' @export
linkTTG.LongitudinalGSF <- function(prior = prior_normal(0, 2), model, ...) {
    LinkComponent(
        key = "link_ttg",
        stan = StanModule("lm-gsf/link_ttg.stan"),
        prior = prior
    )
}

#' @export
linkIdentity.LongitudinalGSF <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    LinkComponent(
        key = "link_identity",
        stan = StanModule("lm-gsf/link_identity.stan"),
        prior = prior
    )
}

#' @export
linkGrowth.LongitudinalGSF <- function(prior = prior_normal(0, 2), model, ...) {
    LinkComponent(
        key = "link_growth",
        stan = StanModule("lm-gsf/link_growth.stan"),
        prior = prior
    )
}


#' @export
linkShrinkage.LongitudinalGSF <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    LinkComponent(
        key = "link_shrinkage",
        stan = StanModule("lm-gsf/link_shrinkage.stan"),
        prior = prior
    )
}

#' @rdname getPredictionNames
#' @export
getPredictionNames.LongitudinalGSF <- function(object, ...) {
    c("b", "s", "g", "phi")
}

#' @rdname getRandomEffectsNames
#' @export
getRandomEffectsNames.LongitudinalGSF <- function(object, ...) {
    c(
        "b" = "lm_gsf_psi_bsld",
        "s" = "lm_gsf_psi_ks",
        "g" = "lm_gsf_psi_kg",
        "phi" = "lm_gsf_psi_phi"
    )
}

# "missing" = no argument provided
# "NULL" = explicit NULL
setClassUnion("empty", c("missing", "NULL"))
setClassUnion("numeric_or_NULL", c("numeric", "NULL"))
setClassUnion("character_or_NULL", c("character", "NULL"))

# merge ----

#' `merge`
#'
#' Merge two `StanModule` or `ParameterList` objects.
#'
#' @param x first module.
#' @param y second module.
#' @param ... additional arguments.
#'
#' @export
# Needs to be S4 for multiple dispatch !
setGeneric(
    name = "merge",
    def = function(x, y, ...) standardGeneric("merge")
)


# show ----

#' Printing of Different Classes
#'
#' These methods print objects of different classes.
#'
#' @name show
#' @aliases show
#'
#' @param object what to print.
#'
#' @export
NULL


# write_stan ----

#' `write_stan`
#'
#' Write the Stan code for a Stan module.
#'
#' @param object the module.
#' @typed destination: "`character` or  `connection`"
#'   Where to write stan code to.
#' @param ... Additional arguments
#'
#' @export
write_stan <- function(object, destination, ...) {
    UseMethod("write_stan")
}

# compileStanModel ----

#' `compileStanModel`
#'
#' Compile the Stan module.
#'
#' @param object the module.
#'
#' @export
compileStanModel <- function(object) {
    UseMethod("compileStanModel")
}


# sampleStanModel ----

#' `sampleStanModel`
#'
#' Sample from a Stan Module.
#'
#' @param object the module.
#' @param ... additional arguments.
#'
#' @export
sampleStanModel <- function(object, ...) {
    UseMethod("sampleStanModel")
}


# as.StanModule ----

#' `as.StanModule`
#'
#' Converts an object into a [`StanModule`].
#'
#' @param object what to convert.
#' @param ... additional options.
#' @family as.StanModule
#' @keywords internal
as.StanModule <- function(object, ...) {
    UseMethod("as.StanModule")
}


#' `getParameters`
#'
#' Extract any modelling parameters as a [`ParameterList`] object
#' from a model.
#'
#' @param object where to obtain the parameters from.
#' @param ... additional options.
#'
#' @export
getParameters <- function(object, ...) {
    UseMethod("getParameters")
}


# extractVariableNames ----

#' Extract Mapping to Standardised Variable Names
#'
#' @description
#' Extract a `list` that maps the variable names in a user-defined
#' `data.frame` to standardised values.
#'
#' @param object the data object.
#' @family extractVariableNames
#' @keywords internal
extractVariableNames <- function(object) {
    UseMethod("extractVariableNames")
}


# initialValues ----

#' `initialValues`
#'
#' Obtain the `list` of initial values to be passed to the Stan sampler.
#'
#' @param object where to get the initial values from.
#' @param n_chains the number of initial values to generate. See details.
#' @param ... Not currently used.
#'
#' @details
#' There are multiple ways of specifying initial values to Stan, see the `init` argument
#' in [cmdstanr::model-method-sample] for full details. Within this package we supply
#' initial values via a list of lists where each inner list contains the initial values
#' for a single chain. As such the `n_chains` argument specifies the number of inner lists
#' to generate.
#'
#' See the Vignette for further details of how to specify initial values.
#'
#' @export
initialValues <- function(object, ...) {
    UseMethod("initialValues")
}


# size ----

#' `size`
#'
#' Obtain the `list` of parameter sizes.
#'
#' @param object where to get the parameter sizes from.
#'
#' @keywords internal
size <- function(object) {
    UseMethod("size")
}


# generateQuantities ----

#' `generateQuantities`
#'
#' Obtain the generated quantities from a Stan Model.
#'
#' @param object object to obtain generated quantities from
#' @param ... additional options.
#'
#' @export
generateQuantities <- function(object, ...) {
    UseMethod("generateQuantities")
}


#' Prepare Data Object
#'
#' @typed object: "`DataSubject` or `DataLongitudinal` or `DataSurvival`"
#'   data object to "harmonise"
#' @typed subject_var: character
#'   the name of the variable containing the subject identifier.
#' @typed subject_ord: character
#'   the expected levels (in order) of the subject identifier.
#' @param ... not used.
#'
#' @details
#' This utility function prepares the datasets in the data objects in order to ensure they
#' are consistent and compatible with each other.
#'
#' In particular it ensures that the `subject` variable, as specified by `DataSubject`,
#' is available in `DataLongitudinal` and `DataSurvival` and that all levels are present
#' in all 3 data objects.
#'
#' It also sorts the datasets to ensure that indexes are consistent e.g. index 1 for
#' `DataSubject@data` corresponds to the same subject as index 1 for `DataSurvival@data`.
#' For `DataLongitudinal` the data is additionally sorted by time and outcome value.
#'
#' @seealso [`DataJoint`], [`DataSurvival`], [`DataSubject`], [`DataLongitudinal`]
#'
#' @keywords internal
#' @return Returns the original object but with the data standardised (see details)
harmonise <- function(object, ...) {
    UseMethod("harmonise")
}


#' @rdname harmonise
harmonise.default <- function(object, ...) {
    NULL
}


#' `as_stan_list`
#'
#' @description
#' Extracts a list of data elements from an object to be used as input
#' to a Stan Model
#'
#' @param object to be converted.
#' @param ... additional options.
#'
#' @family as_stan_list
#' @export
as_stan_list <- function(object, ...) {
    UseMethod("as_stan_list")
}

#' @rdname as_stan_list
#' @export
as_stan_list.default <- function(object, ...) {
    NULL
}


#' `as_print_string`
#'
#' @description
#' Returns the character representation of an object which is suitable
#' for printing to the console
#'
#' @param object to be converted to string.
#' @param ... additional options.
#'
#' @family as_print_string
#' @keywords internal
as_print_string <- function(object, ...) {
    UseMethod("as_print_string")
}

#' Show an Object
#'
#' Prints an object to the console.
#'
#' @param object Object to be printed
#'
#' @name show-object
NULL


#' `brierScore`
#'
#' @description
#' Returns the Brier Score for a given model
#'
#' @param object to calculate Brier Score for.
#' @param ... additional options.
#'
#' @family brierScore
#' @export
brierScore <- function(object, ...) {
    UseMethod("brierScore")
}


#' Generate Simulated Observations
#'
#' @typed object: "`SimLongitudinal` or `SimSurvival`"
#'   object to generate observations from.
#' @typed times_df: data.frame
#'   the times at which to generate observations. See details.
#'
#' @details
#' The `times_df` argument should be a `data.frame` as created by `sampleSubjects` but
#' replicated for each time point at which observations are to be generated. That is if you want
#' to generate observations for times `c(0, 1, 2, 3)` then `times_df` should be created as:
#' ```
#' subject_dat <- sampleSubjects(object, ...)
#' times_df <- tidyr::expand_grid(
#'     subject_dat,
#'     time = c(0, 1, 2, 3)
#'   )
#' ```
#'
#' @export
sampleObservations <- function(object, times_df) {
    UseMethod("sampleObservations")
}


#' Generate Simulated Subjects
#'
#' @typed object: "`SimLongitudinal` or `SimSurvival`"
#'   object to generate subjects from.
#' @typed subjects_df: data.frame
#'   the subjects to generate observations for. See details.
#'
#' @details
#' The `subjects_df` argument should be a `data.frame` with 1 row per desired subject to create
#' with the following columns:
#' - `study` (`factor`) the study identifier.
#' - `arm` (`factor`) the treatment arm identifier.
#' - `subject` (`character`) the subject identifier.
#'
#' This method takes care of generating all the individual subject data required for the
#' [`sampleObservations`] method to generate the observations.
#' @export
sampleSubjects <- function(object, subjects_df) {
    UseMethod("sampleSubjects")
}


#' Generate time windows for evaluating a hazard function
#'
#' @typed object: SurvivalModel
#'   object to generate time windows for.
#' @param ... Not used.
#'
hazardWindows <- function(object, ...) {
    UseMethod("hazardWindows")
}

#' @rdname Quant-Dev
#' @export
as.QuantityGenerator <- function(object, ...) {
    UseMethod("as.QuantityGenerator")
}

#' @rdname Quant-Dev
#' @export
as.QuantityCollapser <- function(object, ...) {
    UseMethod("as.QuantityCollapser")
}


#' Coalesce Time
#'
#' @typed object: Grid
#'   object to coalesce time for.
#' @typed times: numeric
#'   the times to coalesce to.
#' @param ... Not used
#'
#' Method used to replace NULL times on grid objects (if appropriate)
#'
#' @keywords internal
coalesceGridTime <- function(object, times, ...) {
    UseMethod("coalesceGridTime")
}
#' @export
coalesceGridTime.default <- function(object, times, ...) {
    object
}


#' Resolve a Promise
#'
#' @typed object: ANY
#'   an object to resolve.
#' @typed ...: ANY
#'   additional arguments.
#'
#' If `object` is not a promise will just return itself else will resolve the promise
#' and return the promised object.
#'
#' @export
resolvePromise <- function(object, ...) {
    UseMethod("resolvePromise")
}

#' @rdname resolvePromise
#' @export
resolvePromise.default <- function(object, ...) {
    object
}

#' Enable Link Generic
#'
#' @typed object: LongitudinalModel
#'   to enable link for.
#' @param ... Not used.
#'
#' Optional hook method that is called on a [`LongitudinalModel`] only if a link method
#' is provided to [`JointModel`]. This can be used to allow the model to include any
#' optional stan code that is only required if there are links present.
#'
#' @return [`LongitudinalModel`] object
#'
#' @export
enableLink <- function(object, ...) {
    UseMethod("enableLink")
}
#' @export
enableLink.default <- function(object, ...) {
    object
}


#' Enable Generated Quantities Generic
#'
#' @typed object: StanModel
#'   to enable generated quantities for.
#' @param ... Not used.
#'
#' Optional hook method that is called on a [`StanModel`] if attempting to use
#' either [`LongitudinalQuantities`] or [`SurvivalQuantities`]
#'
#' @return [`StanModule`] object
#'
#' @export
enableGQ <- function(object, ...) {
    UseMethod("enableGQ")
}
#' @export
enableGQ.default <- function(object, ...) {
    StanModule()
}


#' Get Prediction Names
#'
#' Utility function that returns the names of the required parameters for predicting
#' survival quantities with [`GridPrediction`].
#'
#' @typed object: LongitudinalModel
#'   A longitudinal model object
#' @param ... Not used.
#' @export
getPredictionNames <- function(object, ...) {
    UseMethod("getPredictionNames")
}

#' @rdname getPredictionNames
#' @export
getPredictionNames.default <- function(object, ...) {
    NULL
}


#' Get Random Effects Names
#'
#' Utility function that returns the names of the random effects parameters.
#' The main use for this is to allow the [`LongitudinalRandomEffects`] function
#' to know which parameters it needs to extract and to what common names
#' it should map the parameters to.
#'
#' @typed object: LongitudinalModel
#'   A longitudinal model object
#' @param ... Not used.
#' @export
getRandomEffectsNames <- function(object, ...) {
    UseMethod("getRandomEffectsNames")
}

#' @rdname getRandomEffectsNames
#' @export
getRandomEffectsNames.default <- function(object, ...) {
    NULL
}


#' As Formula
#'
#' Utility wrapper function to convert an object to a formula.
#' @typed x: ANY
#'   object to convert to a formula.
#' @param ... Not used.
#' @export
as_formula <- function(x, ...) {
    UseMethod("as_formula")
}

#' @importFrom stats as.formula
#' @export
as_formula.default <- function(x, ...) {
    as.formula(x, ...)
}


#' Set Constraints
#'
#' Applies constraints to a prior distribution to ensure any sampled numbers
#' from the distribution fall within the constraints
#'
#' @typed object: Prior
#'   a prior distribution to apply constraints to
#' @typed lower: numeric
#'   lower constraint boundary
#' @typed upper: numeric
#'   upper constraint boundary
#'
#' @export
set_limits <- function(object, lower = -Inf, upper = Inf) {
    UseMethod("set_limits")
}


#' Save Object to File
#'
#' @typed object: ANY
#'   object to save.
#' @typed file: character
#'   file to save object to.
#' @typed ...: ANY
#'   additional arguments.
#'
#' @family saveObject
#' @export
saveObject <- function(object, file, ...) {
    UseMethod("saveObject")
}

#' @include Grid.R
#' @include generics.R
NULL

#' @rdname Grid-Dev
.GridObserved <- setClass(
    "GridObserved",
    contains = "Grid",
    slots = c(
        "subjects" = "character_or_NULL"
    )
)


#' @rdname Grid-Functions
#' @export
GridObserved <- function(subjects = NULL) {
    .GridObserved(
        subjects = subjects
    )
}

#' @rdname Quant-Dev
#' @export
as.QuantityGenerator.GridObserved <- function(object, data, ...) {
    assert_class(data, "DataJoint")
    data_list <- as.list(data)
    subjects <- unlist(as.list(object, data = data), use.names = FALSE)
    unique_visits <- tapply(
        data_list$tumour_time,
        data_list$subject_tumour_index,
        unique
    )
    subject_visits <- unique_visits[data_list$subject_to_index[subjects]]
    visit_lengths <- vapply(subject_visits, length, numeric(1))
    QuantityGeneratorSubject(
        times = unlist(subject_visits, use.names = FALSE),
        subjects = rep(subjects, visit_lengths)
    )
}

#' @rdname Quant-Dev
#' @export
as.QuantityCollapser.GridObserved <- function(object, data, ...) {
    generator <- as.QuantityGenerator(object, data)

    QuantityCollapser(
        times = generator@times,
        groups = generator@subjects,
        indexes = as.list(seq_along(generator@times))
    )
}

#' @export
as.list.GridObserved <- function(x, data, ...) {
    subjects_to_list(x@subjects, data)
}

#' @include generics.R
#' @include Parameter.R
#' @include Prior.R
NULL


#' ParameterList-Shared
#' @typed object: ParameterList
#'   A List of [`Parameter`] Objects.
#' @typed x: ParameterList
#'   A List of [`Parameter`] Objects.
#' @param ... Not Used.
#' @keywords internal
#' @name ParameterList-Shared
NULL


# ParameterList-class ----

#' `ParameterList`
#'
#' This class extends the general [`list`] type for containing [`Parameter`]
#' specifications.
#'
#'

#' @slot parameters (`list`) \cr a list of [`Parameter`] objects
#' @family ParameterList
#' @export ParameterList
#' @exportClass ParameterList
.ParameterList <- setClass(
    Class = "ParameterList",
    slots = c(
        parameters = "list"
    )
)
#' @typed ...: Parameter
#'   which parameter specifications to include.
#' @rdname ParameterList-class
ParameterList <- function(...) {
    .ParameterList(parameters = list(...))
}

# ParameterList-validity ----

setValidity(
    Class = "ParameterList",
    method = function(object) {
        is_parameters <- vapply(
            object@parameters,
            function(x) is(x, "Parameter"),
            logical(1)
        )
        if (!all(is_parameters)) {
            return("all elements must be of class 'Parameter'")
        }
        return(TRUE)
    }
)


# as.StanModule-ParameterList ----

#' `ParameterList` -> `StanModule`
#'
#' Converts a [`ParameterList`] object to a [`StanModule`] object
#'
#' @inheritParams ParameterList-Shared
#'
#' @family ParameterList
#' @family as.StanModule
#' @export
as.StanModule.ParameterList <- function(object, ...) {
    stan_modules <- lapply(
        object@parameters,
        as.StanModule
    )
    assert_that(
        all(vapply(stan_modules, inherits, logical(1), "StanModule"))
    )
    Reduce(merge, stan_modules)
}


#' `ParameterList` -> `list`
#'
#' Converts a ParameterList object to a list of parameter data values
#' for a Stan model.
#'
#' @inheritParams ParameterList-Shared
#'
#' @family as_stan_list
#' @family ParameterList
#' @export
as_stan_list.ParameterList <- function(object, ...) {
    stan_lists <- lapply(
        object@parameters,
        as_stan_list
    )
    assert_that(
        all(vapply(stan_lists, is.list, logical(1)))
    )
    Reduce(append, stan_lists)
}


# merge-ParameterList,ParameterList ----

#' @rdname merge
setMethod(
    f = "merge",
    signature = c(x = "ParameterList", y = "ParameterList"),
    definition = function(x, y) {
        parameters <- append(x@parameters, y@parameters)
        do.call(ParameterList, parameters)
    }
)

# as.list-ParameterList ----

#' `ParameterList` -> `list`
#' @description
#' Returns a named list where each element of the list corresponds
#' to a Stan modelling block e.g. `data`, `model`, etc.
#' @inheritParams ParameterList-Shared
#' @family ParameterList
#' @export
as.list.ParameterList <- function(x, ...) {
    as.list(as.StanModule(x))
}


#' Parameter-List Getter Functions
#' @description
#' Getter functions for the slots of a [`ParameterList`] object
#' @inheritParams ParameterList-Shared
#' @family ParameterList
#' @typed n_chains: integer
#'   the number of chains.
#' @name ParameterList-Getter-Methods
NULL


#' @describeIn ParameterList-Getter-Methods The parameter-list's parameter names
#' @export
names.ParameterList <- function(x) {
    vapply(x@parameters, names, character(1))
}


#' @describeIn ParameterList-Getter-Methods The parameter-list's parameter initial values
#' @export
initialValues.ParameterList <- function(object, n_chains, ...) {
    # Generate initial values as a list of lists. This is to ensure it is in the required
    # format as specified by cmdstanr see the `init` argument of
    # `help("model-method-sample", "cmdstanr")` for more details
    lapply(
        seq_len(n_chains),
        \(i) {
            vals <- lapply(object@parameters, initialValues)
            name <- vapply(object@parameters, names, character(1))
            names(vals) <- name
            vals
        }
    )
}


#' @describeIn ParameterList-Getter-Methods The parameter-list's parameter dimensionality
#' @export
size.ParameterList <- function(object) {
    x <- lapply(object@parameters, size)
    names(x) <- names(object)
    return(x)
}


#' `ParameterList` -> Printable `Character`
#'
#' Converts [`ParameterList`] object into a printable string.
#' @inheritParams ParameterList-Shared
#' @family ParameterList
#' @keywords internal
#' @export
as_print_string.ParameterList <- function(object, ...) {
    x <- vapply(object@parameters, as.character, character(1))
    if (length(x) == 0) {
        x <- "<No Parameters>"
    }
    return(x)
}


#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "ParameterList",
    definition = function(object) {
        chrs <- as_print_string(object)
        string <- paste("   ", chrs) |> paste(collapse = "\n")
        x <- sprintf("\nParameterList Object:\n%s\n\n", string)
        cat(x)
        return(object)
    }
)

#' Calculate Population Hazard Ratios
#'
#' Calculates hazard ratios marginalised over subject specific random effects using the
#' approach proposed by \insertCite{oudenhoven2020marginal}{jmpost}.
#'
#' @typed object: JointModelSamples
#'   samples as drawn from a Joint Model.
#' @typed hr_formula: formula
#'   defines the terms to include in the hazard ratio calculation.
#'   By default this uses the right side of the formula used in the survival model.
#'   Set to `NULL` not include any terms
#' @typed baseline: formula
#'   terms to model baseline hazard using variable `time`.
#'   Default is a B-spline from [splines]: `~bs(time, df = 10)`
#' @typed quantiles: numeric
#'   vector of two values in (0, 1) for calculating quantiles from log hazard ratio
#'   distributions.
#'
#' @references \insertAllCited{}
#'
#' @returns A list containing a summary of parameter distributions as a `data.frame` and a
#' matrix containing the parameter estimates for each sample.
#' @export
#' @importFrom splines bs
populationHR <- function(
    object,
    hr_formula = object@data@survival@formula,
    baseline = ~ bs(time, df = 10),
    quantiles = c(0.025, 0.975)
) {
    assert_class(object, "JointModelSamples")
    assert_formula(hr_formula)
    assert_formula(baseline)
    assert_numeric(
        quantiles,
        lower = 0,
        upper = 1,
        any.missing = FALSE,
        unique = TRUE
    )
    if (!"time" %in% all.vars(baseline)) {
        stop("baseline formula should include a time term.")
    }

    # Extract the variable names used in the data
    subject_var <- object@data@subject@subject
    arm_var <- object@data@subject@arm
    long_time_var <- all.vars(delete.response(terms(
        object@data@longitudinal@formula
    )))
    surv_time_var <- all.vars(object@data@survival@formula[[2]][[2]])
    surv_covs <- all.vars(delete.response(terms(hr_formula)))
    if (!all(surv_covs %in% colnames(object@data@survival@data))) {
        stop("All variables in hr_formula must be in survival data")
    }

    marginal_formula <- stats::reformulate(c(
        attr(terms(baseline), "term.labels"),
        attr(terms(hr_formula), "term.labels")
    ))

    # Get the survival quantities at the observed longitudinal and survival times for each patient:
    times_df <- rbind(
        stats::setNames(
            object@data@longitudinal@data[, c(subject_var, long_time_var)],
            c("subject", "time")
        ),
        stats::setNames(
            object@data@survival@data[, c(subject_var, surv_time_var)],
            c("subject", "time")
        )
    )
    times_df <- times_df[order(times_df$subject, times_df$time), ]
    times_df <- times_df[times_df$time > 0, ]
    times_df <- times_df[!duplicated.data.frame(times_df), ]

    # Generate samples of the log hazard log h_i(t) for each patient i at these time points t.
    grid_spec <- split(times_df$time, times_df$subject)
    log_haz_samples <- SurvivalQuantities(
        object,
        grid = GridManual(grid_spec),
        type = "loghaz"
    )@quantities@quantities |>
        t()

    # Construct \tilde{X} in paper's notation with one row per patient's time
    W_df <- dplyr::left_join(
        times_df,
        stats::setNames(
            object@data@survival@data[, c(subject_var, surv_covs)],
            c("subject", surv_covs)
        ),
        by = "subject"
    )
    W_mat <- model.matrix(marginal_formula, W_df)

    # As model matrix contains baseline and covariates, we don't need the intercept term
    # but we want factor variables encoded relative to the intercept
    W_mat <- W_mat[, colnames(W_mat) != "(Intercept)", drop = FALSE]

    estimates <- stats::lm.fit(x = W_mat, y = log_haz_samples)$coefficients
    tidy_res <- apply(estimates, 1, function(x) {
        quantiles <- stats::quantile(x, probs = quantiles)
        c(mean = mean(x), median = median(x), quantiles)
    }) |>
        t() |>
        data.frame()

    list(summary = tidy_res, estimates)
}

#' @include StanModule.R
#' @include ParameterList.R
#' @include generics.R
NULL

#' `StanModel` Function Arguments
#'
#' The documentation lists all the conventional arguments for wrappers around
#' [StanModel()].
#'
#' @typed stan: StanModule
#'   code containing the Stan code specification.
#' @typed parameters: ParameterList
#'   the parameter specification.
#' @typed parameter: ParameterList
#'   the (single) parameter specification.
#' @typed name: character
#'   display name for the model object.
#' @param ... additional arguments for [StanModel()].
#'
#' @name stanmodel_arguments
#' @keywords internal
NULL

# StanModel-class ----

#' Stan Model Object and Constructor Function
#'
#' @slot stan (`StanModule`)\cr See Arguments.
#' @slot parameters (`ParameterList`)\cr See Arguments.
#' @slot name (`character`)\cr display name for the model object.
#'
#' @export StanModel
#' @exportClass StanModel
#' @family StanModel
.StanModel <- setClass(
    Class = "StanModel",
    slots = list(
        "stan" = "StanModule",
        "parameters" = "ParameterList",
        "name" = "character"
    )
)

# StanModel-constructor ----

#' @inheritParams stanmodel_arguments
#' @rdname StanModel-class
StanModel <- function(stan, parameters, name = "<Unnamed>") {
    .StanModel(
        stan = stan,
        parameters = parameters,
        name = name
    )
}

# as.list-StanModel ----

#' `StanModel` -> `list`
#' @description
#' Returns a named list where each element of the list corresponds
#' to a Stan modelling block e.g. `data`, `model`, etc.
#' @typed x: StanModel
#'   A Stan Model
#' @param ... Not Used.
#' @family StanModel
#' @export
as.list.StanModel <- function(x, ...) {
    as.list(x@stan)
}

# getParameters-StanModel ----

#' @rdname getParameters
#' @export
getParameters.StanModel <- function(object, ...) object@parameters


#' @export
as_print_string.StanModel <- function(object, ...) {
    string <- sprintf(
        "\n%s Model Object with parameters:\n%s\n\n",
        object@name,
        paste("   ", as_print_string(object@parameters)) |>
            paste(collapse = "\n")
    )
    return(string)
}

#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "StanModel",
    definition = function(object) {
        cat(as_print_string(object))
    }
)

#' @rdname initialValues
#' @export
initialValues.StanModel <- function(object, n_chains, ...) {
    initialValues(object@parameters, n_chains)
}

#' `SimSurvival` Function Arguments
#'
#' The documentation lists all the conventional arguments for [`SimSurvival`]
#' constructors.
#'
#' @typed time_max: number
#'   the maximum time to simulate to.
#' @typed time_step: number
#'   the time interval between evaluating the log-hazard function.
#' @typed lambda_censor: number
#'   the censoring rate.
#' @typed beta_cont: number
#'   the continuous covariate coefficient.
#' @typed beta_cat: numeric
#'   the categorical covariate coefficients.
#' @typed loghazard: function
#'   the log hazard function.
#' @typed name: character
#'   the name of the object.
#' @param ... Not Used.
#'
#' @section Hazard Evaluation:
#'
#' Event times are simulated by sampling a cumulative hazard limit from a \eqn{U(0, 1)} distribution
#' for
#' each subject and then counting how much hazard they've been exposed to by evaluating the
#' log-hazard function at a set interval. The `time_max` argument sets the upper bound for the
#' number of time points to evaluate the log-hazard function at with subjects who have not had an
#' event being censored at `time_max`. The `time_step` argument sets the interval at which to
#' evaluate the log-hazard function. Setting smaller values for `time_step` will increase the
#' precision of the simulation at the cost of increased computation time. Likewise, setting large
#' values for `time_max` will minimize the number of censored subjects at the cost of
#' increased computation time.
#'
#' @name SimSurvival-Shared
#' @keywords internal
NULL


#' Abstract Simulation Class for Survival Data
#'
#' @inheritParams SimSurvival-Shared
#' @inheritSection SimSurvival-Shared Hazard Evaluation
#'
#' @slot time_max (`numeric`)\cr See arguments.
#' @slot time_step (`numeric`)\cr See arguments.
#' @slot lambda_censor (`numeric`)\cr See arguments.
#' @slot beta_cont (`numeric`)\cr See arguments.
#' @slot beta_cat (`numeric`)\cr See arguments.
#' @slot loghazard (`function`)\cr See arguments.
#' @slot name (`character`)\cr See arguments.
#' @slot beta_os_cov (`numeric`) Additional regression coefficients for survival models.
#'
#' @family SimSurvival
#' @exportClass SimSurvival
#' @name SimSurvival-class
.SimSurvival <- setClass(
    "SimSurvival",
    slots = c(
        time_max = "numeric",
        time_step = "numeric",
        lambda_censor = "numeric",
        beta_cont = "numeric",
        beta_cat = "numeric",
        beta_os_cov = "numeric",
        loghazard = "function",
        name = "character"
    )
)

#' @rdname SimSurvival-class
#' @export
SimSurvival <- function(
    time_max = 2000,
    time_step = 1,
    lambda_censor = 1 / 3000,
    beta_cont = 0.2,
    beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2),
    loghazard,
    name = "SimSurvival"
) {
    .SimSurvival(
        time_max = time_max,
        time_step = time_step,
        lambda_censor = lambda_censor,
        beta_cont = beta_cont,
        beta_cat = beta_cat,
        loghazard = loghazard,
        name = name
    )
}


#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "SimSurvival",
    definition = function(object) {
        x <- sprintf("\nA %s Object\n\n", as_print_string(object))
        cat(x)
        return(object)
    }
)

#' @rdname as_print_string
#' @exportS3Method NULL
as_print_string.SimSurvival <- function(object, ...) {
    return(object@name)
}


#' Construct Time Intervals
#'
#' @typed object: SimSurvival
#'   the survival simulation object to create evaluation points for.
#' @param ... Not Used.
#'
#' @return A `tibble` with `lower`, `upper`, `time`, `eval` and `width`.
#' @keywords internal
#' @exportS3Method NULL
hazardWindows.SimSurvival <- function(object, ...) {
    times <- seq(0, object@time_max, object@time_step)
    bound_lower <- times[-length(times)]
    bound_upper <- times[-1]
    bound_width <- bound_upper - bound_lower
    mid_point <- bound_upper - (bound_width / 2)
    tibble::tibble(
        lower = bound_lower,
        upper = bound_upper,
        midpoint = mid_point,
        width = bound_width
    )
}

#' @rdname sampleSubjects
#' @export
sampleSubjects.SimSurvival <- function(object, subjects_df) {
    subjects_df |>
        dplyr::mutate(cov_cont = stats::rnorm(dplyr::n())) |>
        dplyr::mutate(
            cov_cat = factor(
                sample(
                    names(object@beta_cat),
                    replace = TRUE,
                    size = dplyr::n()
                ),
                levels = names(object@beta_cat)
            )
        ) |>
        dplyr::mutate(
            log_haz_cov = .data$cov_cont *
                object@beta_cont +
                object@beta_cat[.data$cov_cat]
        ) |>
        dplyr::mutate(survival = stats::runif(dplyr::n())) |>
        dplyr::mutate(chazard_limit = -log(.data$survival)) |>
        dplyr::mutate(time_cen = stats::rexp(dplyr::n(), object@lambda_censor))
}


#' @rdname sampleObservations
#' @export
sampleObservations.SimSurvival <- function(object, times_df) {
    assert_that(
        all(times_df$time >= 0),
        msg = "All time points must be greater than or equal to 0"
    )

    os_dat_chaz <- times_df |>
        dplyr::mutate(log_bl_haz = object@loghazard(.data$midpoint)) |>
        # Fix to avoid issue with log(0) = NaN values
        dplyr::mutate(
            log_bl_haz = dplyr::if_else(
                .data$midpoint == 0,
                -999,
                .data$log_bl_haz
            )
        ) |>
        dplyr::mutate(
            hazard_instant = exp(
                .data$log_bl_haz + .data$log_haz_cov + .data$log_haz_link
            )
        ) |>
        # Reset Inf values to large number to avoid NaN issues downstream
        # This is suitable as Hazard limits tend to be in the range of -10 to 10 so large numbers
        # are essentially equivalent to infinity for simulation purposes
        dplyr::mutate(
            hazard_instant = dplyr::if_else(
                .data$hazard_instant == Inf,
                999,
                .data$hazard_instant
            )
        ) |>
        dplyr::mutate(
            hazard_instant = dplyr::if_else(
                .data$hazard_instant == -Inf,
                -999,
                .data$hazard_instant
            )
        ) |>
        dplyr::mutate(hazard_interval = .data$hazard_instant * .data$width) |>
        dplyr::group_by(.data$subject) |>
        dplyr::mutate(chazard = cumsum(.data$hazard_interval)) |>
        dplyr::ungroup()

    os_had_event <- os_dat_chaz |>
        dplyr::filter(.data$chazard >= .data$chazard_limit) |>
        dplyr::group_by(.data$subject) |>
        dplyr::slice(1) |>
        dplyr::ungroup() |>
        dplyr::mutate(event = 1)

    os_had_censor <- os_dat_chaz |>
        dplyr::filter(!.data$subject %in% os_had_event$subject) |>
        dplyr::group_by(.data$subject) |>
        dplyr::slice(dplyr::n()) |>
        dplyr::ungroup() |>
        dplyr::mutate(event = 0)

    if (!(nrow(os_had_censor) == 0)) {
        message(sprintf(
            "INFO: %i subject(s) did not die before max(times)",
            nrow(os_had_censor)
        ))
    }

    os_dat_complete <- os_had_event |>
        dplyr::bind_rows(os_had_censor) |>
        dplyr::mutate(real_time = .data$time) |>
        dplyr::mutate(
            event = dplyr::if_else(
                .data$real_time <= .data$time_cen,
                .data$event,
                0
            )
        ) |>
        dplyr::mutate(
            time = dplyr::if_else(
                .data$real_time <= .data$time_cen,
                .data$real_time,
                .data$time_cen
            )
        ) |>
        dplyr::arrange(.data$subject)

    keep_cols <- colnames(os_dat_complete) %in%
        c("subject", "study", "arm", "time", "event", "cov_cont", "cov_cat")
    os_dat_complete[, keep_cols]
}


#' Simulate Survival Data from a Weibull Proportional Hazard Model
#'
#' @typed lambda: number
#'   the scale parameter.
#' @typed gamma: number
#'   the shape parameter.
#'
#' @inheritParams SimSurvival-Shared
#' @inheritSection SimSurvival-Shared Hazard Evaluation
#'
#' @family SimSurvival
#'
#' @export
SimSurvivalWeibullPH <- function(
    lambda,
    gamma,
    time_max = 2000,
    time_step = 1,
    lambda_censor = 1 / 3000,
    beta_cont = 0.2,
    beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2)
) {
    SimSurvival(
        time_max = time_max,
        time_step = time_step,
        lambda_censor = lambda_censor,
        beta_cont = beta_cont,
        beta_cat = beta_cat,
        loghazard = function(time) {
            log(lambda) + log(gamma) + (gamma - 1) * log(time)
        },
        name = "SimSurvivalWeibullPH"
    )
}

#' Simulate Survival Data from a Log-Logistic Proportional Hazard Model
#'
#' @typed a: number
#'   the scale parameter.
#' @typed b: number
#'   the shape parameter.
#'
#' @inheritParams SimSurvival-Shared
#' @inheritSection SimSurvival-Shared Hazard Evaluation
#'
#' @family SimSurvival
#' @export
SimSurvivalLogLogistic <- function(
    a,
    b,
    time_max = 2000,
    time_step = 1,
    lambda_censor = 1 / 3000,
    beta_cont = 0.2,
    beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2)
) {
    SimSurvival(
        time_max = time_max,
        time_step = time_step,
        lambda_censor = lambda_censor,
        beta_cont = beta_cont,
        beta_cat = beta_cat,
        loghazard = function(time) {
            c1 <- -log(a) + log(b) + (b - 1) * (-log(a) + log(time))
            c2 <- log(1 + (time / a)^b)
            return(c1 - c2)
        },
        name = "SimSurvivalLogLogistic"
    )
}


#' Simulate Survival Data from a Exponential Proportional Hazard Model
#'
#' @typed lambda: number
#'   the rate parameter.
#'
#' @inheritParams SimSurvival-Shared
#' @inheritSection SimSurvival-Shared Hazard Evaluation
#'
#' @family SimSurvival
#'
#' @export
SimSurvivalExponential <- function(
    lambda,
    time_max = 2000,
    time_step = 1,
    lambda_censor = 1 / 3000,
    beta_cont = 0.2,
    beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2)
) {
    SimSurvival(
        time_max = time_max,
        time_step = time_step,
        lambda_censor = lambda_censor,
        beta_cont = beta_cont,
        beta_cat = beta_cat,
        loghazard = function(time) {
            log(lambda)
        },
        name = "SimSurvivalExponential"
    )
}


#' Simulate Survival Data from a Gamma Proportional Hazard Model
#'
#' @typed k: number
#'   the shape parameter.
#' @typed theta: number
#'   the scale parameter.
#'
#' @inheritParams SimSurvival-Shared
#' @inheritSection SimSurvival-Shared Hazard Evaluation
#'
#' @family SimSurvival
#'
#' @importFrom stats dgamma pgamma
#'
#' @export
SimSurvivalGamma <- function(
    k,
    theta,
    time_max = 2000,
    time_step = 1,
    lambda_censor = 1 / 3000,
    beta_cont = 0.2,
    beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2)
) {
    SimSurvival(
        time_max = time_max,
        time_step = time_step,
        lambda_censor = lambda_censor,
        beta_cont = beta_cont,
        beta_cat = beta_cat,
        loghazard = function(time) {
            dgamma(time, k, scale = theta, log = TRUE) -
                pgamma(time, k, scale = theta, lower.tail = FALSE, log.p = TRUE)
        },
        name = "SimSurvivalGamma"
    )
}

#' @include StanModule.R
#' @include LongitudinalModel.R
#' @include ParameterList.R
#' @include LinkComponent.R
#' @include Prior.R
NULL


#' `Link` Function Arguments
#'
#' This exists just to contain all the common arguments for [`Link`] methods.
#'
#' @typed x: Link
#'   a link object.
#' @typed object: Link
#'   a link object.
#' @param ... Not Used.
#'
#' @name Link-Shared
#' @keywords internal
NULL


#' `Link`
#'
#' @slot components (`list`)\cr a list of [`LinkComponent`] or [`PromiseLinkComponent`] objects.
#' @slot resolved (`logical`)\cr indicates if all the `components` have been resolved.
#'
#' @typed ...: "[`LinkComponent`] or [`PromiseLinkComponent`]"
#'   an arbitrary number of link components.
#'
#' @description
#' Simple container class to enable the use of multiple link components in a joint model.
#' Note that the constructor of this object is idempotent e.g. `Link(Link(x)) == Link(x)`
#'
#' @examples
#' Link(
#'     linkDSLD(),
#'     linkTTG()
#'   )
#'
#' @family Link
#' @name Link-class
#' @exportClass Link
.Link <- setClass(
    Class = "Link",
    slots = list(
        components = "list",
        resolved = "logical"
    )
)

#' @rdname Link-class
#' @export
Link <- function(...) {
    components <- list(...)

    # If the input is already a Link object, return it (e.g. implement
    # a constructor that is idempotent)
    if (length(components) == 1 && is(components[[1]], "Link")) {
        return(components[[1]])
    }

    .Link(
        components = components,
        resolved = !any(vapply(
            components,
            \(x) is(x, "PromiseLinkComponent"),
            logical(1)
        ))
    )
}


#' Resolve any promises
#'
#' Loops over all components and ensures that any [`PromiseLinkComponent`] objects
#' are resolved to [`LinkComponent`] objects.
#'
#' @typed object: Link
#'   a link object.
#' @typed model: LongitudinalModel
#'   the model object.
#' @param ... Not Used.
#'
#' @export
resolvePromise.Link <- function(object, model, ...) {
    if (length(object) == 0) {
        return(object)
    }
    assert_that(
        is(model, "LongitudinalModel"),
        msg = "model must be of class `LongitudinalModel`"
    )
    do.call(Link, lapply(object@components, resolvePromise, model = model))
}


setValidity(
    Class = "Link",
    method = function(object) {
        for (i in object@components) {
            if (!(is(i, "LinkComponent") || is(i, "PromiseLinkComponent"))) {
                return(
                    "All components must be of class `LinkComponent` or `PromiseLinkComponent`"
                )
            }
        }

        contains_promise <- any(
            vapply(
                object@components,
                \(x) is(x, "PromiseLinkComponent"),
                logical(1)
            )
        )
        if (contains_promise & object@resolved) {
            return("Object cannot be resolved if it contains promises")
        }

        if (length(object@resolved) > 1) {
            return("The `resolved` slot must be a logical scalar")
        }
        return(TRUE)
    }
)


#' `Link` -> `StanModule`
#'
#' Converts a [`Link`] object to a [`StanModule`] object
#'
#' @inheritParams Link-Shared
#'
#' @family Link
#' @family as.StanModule
#' @export
as.StanModule.Link <- function(object, ...) {
    if (length(object@components) == 0) {
        return(StanModule("base/link_none.stan"))
    }

    keys <- vapply(
        object@components,
        function(x) x@key,
        character(1)
    )

    base_stan <- StanModule(
        decorated_render(
            .x = read_stan("base/link.stan"),
            items = as.list(keys)
        )
    )

    stan_list <- lapply(
        object@components,
        as.StanModule
    )

    stan <- Reduce(
        merge,
        append(base_stan, stan_list)
    )
    return(stan)
}


#' `Link` -> `list`
#'
#' @inheritParams Link-Shared
#'
#' @description
#' Returns a named list where each element of the list corresponds
#' to a Stan modelling block e.g. `data`, `model`, etc.
#'
#' @family Link
#' @export
as.list.Link <- function(x, ...) {
    as.list(as.StanModule(x, ...))
}


#' @export
#' @rdname getParameters
getParameters.Link <- function(object, ...) {
    parameters_list <- lapply(
        object@components,
        getParameters,
        ...
    )
    Reduce(
        merge,
        parameters_list
    )
}


#' @rdname initialValues
#' @export
initialValues.Link <- function(object, ...) {
    unlist(
        lapply(object@components, initialValues),
        recursive = FALSE
    )
}


#' `Link` -> `list`
#'
#' @inheritParams Link-Shared
#'
#' @description
#' Returns the number of link components within the [`Link`] object
#'
#' @family Link
#' @export
length.Link <- function(x) {
    length(x@components)
}


#' @export
as_print_string.Link <- function(object, ...) {
    if (length(object) == 0) {
        return("\nNo Link")
    }

    strings <- vapply(object@components, as_print_string, character(1))

    paste(
        c(
            "\nLink with the following components/parameters:",
            paste0("    ", strings)
        ),
        collapse = "\n"
    )
}


#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "Link",
    definition = function(object) {
        cat(paste0(as_print_string(object), "\n"))
    }
)

#' @include generics.R
#' @include Link.R
#' @include LongitudinalModel.R
#' @include SurvivalModel.R
#' @include StanModule.R
#' @include StanModel.R
#' @include Parameter.R
NULL


#' @rdname getParameters
#' @export
getParameters.default <- function(object, ...) {
    if (missing(object) || is.null(object)) {
        return(NULL)
    }
    stop(sprintf(
        "No default method implemented for getParameters(<%s>)",
        typeof(object)
    ))
}


# merge ----

## merge-StanModel,NULL ----

#' @rdname merge
setMethod(
    "merge",
    signature = c("StanModel", "NULL"),
    definition = function(x, y, ...) x@stan
)

## merge-NULL,StanModel ----

#' @rdname merge
setMethod(
    "merge",
    signature = c("NULL", "StanModel"),
    definition = function(x, y, ...) y@stan
)

## merge-StanModule,NULL ----

#' @rdname merge
setMethod(
    "merge",
    signature = c("StanModule", "NULL"),
    definition = function(x, y, ...) x
)

## merge-NULL,StanModule ----

#' @rdname merge
setMethod(
    "merge",
    signature = c("NULL", "StanModule"),
    definition = function(x, y, ...) y
)

## merge-ParameterList,NULL ----

#' @rdname merge
setMethod(
    "merge",
    signature = c("ParameterList", "NULL"),
    definition = function(x, y, ...) x
)

## merge-NULL,ParameterList ----

#' @rdname merge
setMethod(
    "merge",
    signature = c("NULL", "ParameterList"),
    definition = function(x, y, ...) y
)

## merge-NULL,NULL ----

#' @rdname merge
setMethod(
    "merge",
    signature = c("NULL", "NULL"),
    definition = function(x, y, ...) NULL
)

#' @include Grid.R
#' @include generics.R
NULL


#' @rdname Grid-Dev
.GridPopulation <- setClass(
    "GridPopulation",
    contains = "Grid",
    slots = c(
        "times" = "numeric_or_NULL"
    )
)

#' @rdname Grid-Functions
#' @export
GridPopulation <- function(times = NULL) {
    .GridPopulation(
        times = times
    )
}

#' @rdname Quant-Dev
#' @export
as.QuantityGenerator.GridPopulation <- function(object, data, ...) {
    assert_class(data, "DataJoint")
    data_list <- as.list(data)
    validate_time_grid(object@times)

    n_times <- length(object@times)
    n_quant <- length(data_list$pop_study_index)

    QuantityGeneratorPopulation(
        times = rep(object@times, each = n_quant),
        arms = rep(
            names(data_list$arm_to_index)[data_list$pop_arm_index],
            n_times
        ),
        studies = rep(
            names(data_list$study_to_index)[data_list$pop_study_index],
            n_times
        )
    )
}

#' @rdname Quant-Dev
#' @export
as.QuantityCollapser.GridPopulation <- function(object, data, ...) {
    assert_class(data, "DataJoint")
    data_list <- as.list(data)
    generator <- as.QuantityGenerator(object, data)
    QuantityCollapser(
        times = generator@times,
        groups = sprintf(
            "arm=%s; study=%s",
            generator@arms,
            generator@studies
        ),
        indexes = as.list(seq_along(generator@times))
    )
}


#' @export
as.list.GridPopulation <- function(x, data, ...) {
    stop("`as.list()` is not implemented for `GridPopulation` objects")
}


#' @rdname coalesceGridTime
#' @export
coalesceGridTime.GridPopulation <- function(object, times, ...) {
    if (is.null(object@times)) {
        object <- GridPopulation(
            times = times
        )
    }
    object
}

#' Abstract Simulation Class for Longitudinal Data
#'
#' @typed times: numeric
#'   the times to generate observations at.
#'
#' @description
#' This class exists to be extended by other classes that simulate longitudinal data.
#' It is not intended to be used directly.
#' @name SimLongitudinal-class
#' @family SimLongitudinal
#' @exportClass SimLongitudinal
.SimLongitudinal <- setClass(
    "SimLongitudinal",
    slots = list(
        times = "numeric"
    )
)

#' @rdname SimLongitudinal-class
#' @export
SimLongitudinal <- function(times = seq(0, 100, 50)) {
    .SimLongitudinal(times = times)
}


#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "SimLongitudinal",
    definition = function(object) {
        x <- sprintf("\nA %s Object\n\n", as_print_string(object))
        cat(x)
        return(object)
    }
)

#' @rdname as_print_string
#' @exportS3Method NULL
as_print_string.SimLongitudinal <- function(object, ...) {
    return("SimLongitudinal")
}

#' @include generics.R
#' @include Prior.R
NULL


#' `Parameter` Function Arguments
#'
#' The documentation lists all the conventional arguments for [`Parameter`]
#' constructors.
#'
#' @typed x: Parameter
#'   a prior Distribution
#' @typed object: Parameter
#'   a prior Distribution
#' @param ... Not Used.
#'
#' @name Parameter-Shared
#' @keywords internal
NULL


setClassUnion(name = "numeric_OR_character", c("numeric", "character"))

# Parameter-class ----

#' `Parameter`
#'
#' Stores the name, the prior distribution and the size of a parameter.
#' If `size` is a string then this indicates the name of the variable
#' within the stan data object that specifies the size of this parameter.
#'
#' @slot name (`string`)\cr of the parameter.
#' @slot prior (`Prior`)\cr for the parameter.
#' @slot size (`numeric` or `string`)\cr dimension of the parameter.
#'
#' @family Parameter
#' @exportClass Parameter
#' @export Parameter
.Parameter <- setClass(
    Class = "Parameter",
    slots = list(
        "name" = "character",
        "prior" = "Prior",
        "size" = "numeric_OR_character"
    )
)
#' @typed prior: Prior
#'   for the parameter.
#' @typed name: string
#'   of the parameter.
#' @typed size: "`numeric` or `string`"
#'   dimension of the parameter.
#' @rdname Parameter-class
Parameter <- function(prior, name, size = 1) {
    .Parameter(
        prior = prior,
        name = name,
        size = size
    )
}
setValidity(
    Class = "Parameter",
    method = function(object) {
        if (!length(object@name) == 1) {
            return("Name must be a length 1 character vector")
        }
        if (is.character(object@size)) {
            if (!length(object@size) == 1) {
                return(
                    "Size must be a numeric vector or length 1 character vector"
                )
            }
        }
        return(TRUE)
    }
)


#' `Parameter` -> `StanModule`
#'
#' Converts a [`Parameter`] object to a [`StanModule`] object
#'
#' @inheritParams Parameter-Shared
#'
#' @family Parameter
#' @family as.StanModule
#' @export
as.StanModule.Parameter <- function(object, ...) {
    as.StanModule(object@prior, name = object@name)
}


#' `Parameter` -> `list`
#'
#' Converts a Parameter object to a list of parameter data values
#' for a Stan model.
#'
#' @inheritParams Parameter-Shared
#'
#' @family as_stan_list
#' @family Parameter
#' @export
as_stan_list.Parameter <- function(object, ...) {
    as_stan_list(object@prior, name = object@name)
}


#' Parameter Getter Functions
#'
#' @typed x: Paramater
#'   A model parameter
#' @typed object: Paramater
#'   A model parameter
#' @param ... Not used.
#'
#' @description
#' Getter functions for the slots of a [`Parameter`] object
#' @family Parameter
#' @name Parameter-Getter-Methods
NULL

#' @describeIn Parameter-Getter-Methods The parameter's name
#' @export
names.Parameter <- function(x) x@name

#' @describeIn Parameter-Getter-Methods The parameter's initial values
#' @export
initialValues.Parameter <- function(object, ...) initialValues(object@prior)

#' @describeIn Parameter-Getter-Methods The parameter's dimensionality
#' @export
size.Parameter <- function(object) object@size


#' `Parameter` -> `Character`
#'
#' Converts a [`Parameter`] object to a character vector
#' @inheritParams Parameter-Shared
#' @family Parameter
#' @export
as.character.Parameter <- function(x, ...) {
    paste0(x@name, " ~ ", as.character(x@prior))
}


#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "Parameter",
    definition = function(object) {
        x <- sprintf("\nParameter Object:\n   %s\n\n", as.character(object))
        cat(x)
        return(object)
    }
)

#' @include generics.R
#' @include Grid.R
NULL

#' @rdname Quant-Dev
.QuantityGeneratorPopulation <- setClass(
    "QuantityGeneratorPopulation",
    contains = "QuantityGenerator",
    slots = c(
        "times" = "numeric",
        "studies" = "character_or_NULL",
        "arms" = "character_or_NULL"
    )
)


#' @rdname Quant-Dev
QuantityGeneratorPopulation <- function(times, studies = NULL, arms = NULL) {
    .QuantityGeneratorPopulation(
        times = times,
        studies = studies,
        arms = arms
    )
}


setValidity(
    "QuantityGeneratorPopulation",
    function(object) {
        if (length(object@times) != length(object@arms)) {
            return("Length of `times` and `arms` must be equal")
        }
        if (length(object@times) != length(object@studies)) {
            return("Length of `times` and `studies` must be equal")
        }
        return(TRUE)
    }
)


#' @rdname as_stan_list.QuantityGenerator
#' @export
as_stan_list.QuantityGeneratorPopulation <- function(object, data, ...) {
    assert_that(
        is(data, "DataJoint")
    )
    ret <- list()
    data_list <- as.list(data)
    ret[["gq_times"]] <- object@times
    ret[["gq_n_quant"]] <- length(object@arms)
    ret[["gq_long_pop_arm_index"]] <- data_list$arm_to_index[object@arms]
    ret[["gq_long_pop_study_index"]] <- data_list$study_to_index[object@studies]

    # Sanity checks
    assert_that(
        length(ret[["gq_long_pop_arm_index"]]) ==
            length(ret[["gq_long_pop_study_index"]]),
        length(ret[["gq_long_pop_study_index"]]) == length(ret[["gq_times"]]),
        length(ret[["gq_long_pop_study_index"]]) == ret[["gq_n_quant"]],
        all(!is.na(ret[["gq_long_pop_arm_index"]])),
        all(!is.na(ret[["gq_long_pop_study_index"]]))
    )
    return(ret)
}

#' @include SimLongitudinal.R
#' @include generics.R
NULL

#' Simulate Longitudinal Data from a Random Slope Model
#'
#' @typed times: numeric
#'   the times to generate observations at.
#' @typed intercept: numeric
#'   the mean baseline value for each study.
#' @typed slope_mu: numeric
#'   the population slope for each treatment arm.
#' @typed slope_sigma: numeric
#'   the random slope standard deviation for each treatment arm.
#' @typed sigma: number
#'   the variance of the longitudinal values.
#' @typed link_dsld: number
#'   the link coefficient for the DSLD contribution.
#' @typed link_identity: number
#'   the link coefficient for the identity contribution.
#'
#' @slot intercept (`numeric`)\cr See arguments.
#' @slot slope_mu (`numeric`)\cr See arguments.
#' @slot slope_sigma (`numeric`)\cr See arguments.
#' @slot sigma (`numeric`)\cr See arguments.
#' @slot link_dsld (`numeric`)\cr See arguments.
#' @slot link_identity (`numeric`)\cr See arguments.
#'
#' @family SimLongitudinal
#' @name SimLongitudinalRandomSlope-class
#' @exportClass SimLongitudinalRandomSlope
.SimLongitudinalRandomSlope <- setClass(
    "SimLongitudinalRandomSlope",
    contains = "SimLongitudinal",
    slots = c(
        intercept = "numeric",
        slope_mu = "numeric",
        slope_sigma = "numeric",
        sigma = "numeric",
        link_dsld = "numeric",
        link_identity = "numeric"
    )
)

#' @rdname SimLongitudinalRandomSlope-class
#' @export
SimLongitudinalRandomSlope <- function(
    times = c(-100, -50, 0, 50, 100, 150, 250, 350, 450, 550),
    intercept = 50,
    slope_mu = c(0.01, 0.03),
    slope_sigma = c(0.5, 0.6),
    sigma = 2,
    link_dsld = 0,
    link_identity = 0
) {
    if (length(slope_sigma) == 1) {
        slope_sigma <- rep(slope_sigma, length(slope_mu))
    }

    .SimLongitudinalRandomSlope(
        times = times,
        intercept = intercept,
        slope_mu = slope_mu,
        slope_sigma = slope_sigma,
        sigma = sigma,
        link_dsld = link_dsld,
        link_identity = link_identity
    )
}

#' @rdname as_print_string
#' @exportS3Method NULL
as_print_string.SimLongitudinalRandomSlope <- function(object, ...) {
    return("SimLongitudinalRandomSlope")
}

#' @rdname sampleObservations
#' @export
sampleObservations.SimLongitudinalRandomSlope <- function(object, times_df) {
    times_df |>
        dplyr::mutate(
            err = stats::rnorm(dplyr::n(), 0, object@sigma),
            sld_mu = .data$intercept + .data$slope_ind * .data$time,
            sld = .data$sld_mu + .data$err,
            log_haz_link = object@link_dsld *
                .data$slope_ind +
                object@link_identity * .data$sld_mu
        )
}

#' @rdname sampleSubjects
#' @export
sampleSubjects.SimLongitudinalRandomSlope <- function(object, subjects_df) {
    assert_that(
        is.factor(subjects_df[["study"]]),
        is.factor(subjects_df[["arm"]])
    )

    assert_that(
        length(object@slope_mu) == nlevels(subjects_df[["arm"]]),
        msg = "`length(slope_mu)` should be equal to the number of arms"
    )

    assert_that(
        length(object@slope_sigma) == nlevels(subjects_df[["arm"]]),
        msg = "`length(slope_sigma)` should be equal to the number of arms"
    )

    assert_that(
        length(object@intercept) == nlevels(subjects_df[["study"]]),
        msg = "`length(intercept)` should be equal to the number of studies"
    )

    assert_that(
        nrow(subjects_df) == length(unique(subjects_df[["subject"]])),
        msg = "The number of rows in `subjects_df` should be equal to the number of unique subjects"
    )

    subjects_df |>
        dplyr::mutate(intercept = object@intercept[as.numeric(.data$study)]) |>
        dplyr::mutate(
            slope_ind = stats::rnorm(
                n = dplyr::n(),
                mean = object@slope_mu[as.numeric(.data$arm)],
                sd = object@slope_sigma[as.numeric(.data$arm)]
            )
        )
}

#' @include SurvivalModel.R
NULL

# SurvivalLogLogistic-class ----

#' `SurvivalLogLogistic`
#'
#' This class extends the general [`SurvivalModel`] class for using the
#' log-logistic survival model.
#'
#' @exportClass SurvivalLogLogistic
.SurvivalLogLogistic <- setClass(
    Class = "SurvivalLogLogistic",
    contains = "SurvivalModel"
)

# SurvivalLogLogistic-constructors ----

#' @rdname SurvivalLogLogistic-class
#'
#' @typed a: Prior
#'   Prior distribution for the scale parameter `a`.
#' @typed b: Prior
#'   Prior distribution for the shape parameter `b`.
#' @typed beta: Prior
#'   Prior distribution for covariates coefficients `beta`.
#'
#' @export
SurvivalLogLogistic <- function(
    a = prior_lognormal(log(0.1), 5),
    b = prior_gamma(2, 5),
    beta = prior_normal(0, 2)
) {
    .SurvivalLogLogistic(
        SurvivalModel(
            name = "Log-Logistic",
            stan = StanModule("sm-loglogistic/model.stan"),
            parameters = ParameterList(
                Parameter(name = "sm_loglogis_a", prior = a, size = 1),
                Parameter(name = "sm_loglogis_b", prior = b, size = 1),
                Parameter(
                    name = "beta_os_cov",
                    prior = beta,
                    size = "p_os_cov_design"
                )
            )
        )
    )
}

#' @include generics.R
NULL


#' Standard Links
#'
#' @typed prior: Prior
#'   A [`Prior`] object.
#' @typed model: LongitudinalModel
#'   A [`LongitudinalModel`] object.
#' @param ... Not used.
#'
#' @description
#' These functions are used to enable the use of the corresponding link function between
#' the survival and longitudinal models in a joint model. Note that the exact implementation
#' of the link function is model specific, see
#' \code{vignette("Statistical Specifications", package = "jmpost")} for more details.
#'
#' @name standard-link-user
NULL


#' @describeIn standard-link-user No link (fit the survival and longitudinal models independently)
#' @export
linkNone <- function() {
    Link()
}


#' @describeIn standard-link-user Time to growth link
#' @export
linkTTG <- function(prior, model = PromiseLongitudinalModel(), ...) {
    UseMethod("linkTTG", model)
}
#' @export
linkTTG.PromiseLongitudinalModel <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    PromiseLinkComponent(fun = linkTTG, prior = prior, key = "link_ttg")
}
#' @export
linkTTG.default <- function(prior, model, ...) {
    stop(sprintf(
        "Method `linkTTG` is not available for `%s`",
        class(model)[[1]]
    ))
}


#' @describeIn standard-link-user Derivative of the SLD over time link
#' @export
linkDSLD <- function(prior, model = PromiseLongitudinalModel(), ...) {
    UseMethod("linkDSLD", model)
}
#' @export
linkDSLD.PromiseLongitudinalModel <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    PromiseLinkComponent(fun = linkDSLD, prior = prior, key = "link_dsld")
}
#' @export
linkDSLD.default <- function(prior, model, ...) {
    stop(sprintf(
        "Method `linkDSLD` is not available for `%s`",
        class(model)[[1]]
    ))
}


#' @describeIn standard-link-user Current SLD value link
#' @export
linkIdentity <- function(prior, model = PromiseLongitudinalModel(), ...) {
    UseMethod("linkIdentity", model)
}
#' @export
linkIdentity.PromiseLongitudinalModel <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    PromiseLinkComponent(
        fun = linkIdentity,
        prior = prior,
        key = "link_identity"
    )
}
#' @export
linkIdentity.default <- function(prior, model, ...) {
    stop(sprintf(
        "Method `linkIdentity` is not available for `%s`",
        class(model)[[1]]
    ))
}


#' @describeIn standard-link-user Growth Parameter link
#' @export
linkGrowth <- function(prior, model = PromiseLongitudinalModel(), ...) {
    UseMethod("linkGrowth", model)
}
#' @export
linkGrowth.PromiseLongitudinalModel <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    PromiseLinkComponent(fun = linkGrowth, prior = prior, key = "link_growth")
}
#' @export
linkGrowth.default <- function(prior, model, ...) {
    stop(sprintf(
        "Method `linkGrowth` is not available for `%s`",
        class(model)[[1]]
    ))
}


#' @describeIn standard-link-user Shrinkage Parameter link
#' @export
linkShrinkage <- function(prior, model = PromiseLongitudinalModel(), ...) {
    UseMethod("linkShrinkage", model)
}
#' @export
linkShrinkage.PromiseLongitudinalModel <- function(
    prior = prior_normal(0, 2),
    model,
    ...
) {
    PromiseLinkComponent(
        fun = linkShrinkage,
        prior = prior,
        key = "link_shrinkage"
    )
}
#' @export
linkShrinkage.default <- function(prior, model, ...) {
    stop(sprintf(
        "Method `linkShrinkage` is not available for `%s`",
        class(model)[[1]]
    ))
}

#' jmpost settings
#'
#' @description
#' Define settings that modify the behaviour of the `jmpost` package
#'
#' Each of the following are the name of options that can be set via:
#' ```
#' options(<option_name> = <value>)
#' ```
#'
#' ## `jmpost.prior_shrinkage`
#'
#' Default = `0.5`
#'
#' By default all initial values are drawn as random sample from the respective prior
#' distribution with a shrinkage factor towards the mean. That is:
#' ```
#' initial_value = prior_mean * prior_shrinkage + (1 - prior_shrinkage) * prior_sample
#' ```
#' This setting controls the shrinkage factor. A value of 0 means no shrinkage (i.e.
#' pure random draw) whilst a value of 1 means the initial value is just the mean.
#'
#' ## `jmpost.cache_dir`
#'
#' Default = `tempfile()`
#'
#' Directory to store compiled stan models in. If not set, a temporary directory is used for
#' the given R session. Can also be set via the environment variable `JMPOST_CACHE_DIR`.
#'
#'
#'
#' ## `jmpost.gauss_quad_n`
#'
#' Default = 15
#'
#' In most cases the survival function of the joint model does not have a closed form
#' and as such it is calculated by integrating the hazard function. `jmpost` estimates this
#' via Gaussian Quadrature, in particular it uses [`statmod::gauss.quad`] with
#' `kind = "legendre"` to create the nodes and weights.
#'
#' This option specifies the `n` argument in the call to [`statmod::gauss.quad`]. In general
#' higher values of `n` lead to better accuracy of the approximation but at the cost of
#' increased computational time.
#'
#' @examples
#' \dontrun{
#' options(jmpost.prior_shrinkage = 0.5)
#' }
#' @name jmpost-settings
set_options <- function() {
    cache_dir <- Sys.getenv("JMPOST_CACHE_DIR")

    if (cache_dir == "" || is.null(cache_dir)) {
        cache_dir <- tempfile()
    }

    current_opts <- names(options())
    jmpost_opts <- list(
        jmpost.cache_dir = cache_dir,
        jmpost.prior_shrinkage = 0.5,
        jmpost.gauss_quad_n = 15
    )
    for (opt in names(jmpost_opts)) {
        if (!opt %in% current_opts) {
            options(jmpost_opts[opt])
        }
    }
}

#' @include generics.R
#' @include Grid.R
NULL


#' @rdname Quant-Dev
.QuantityGeneratorSubject <- setClass(
    "QuantityGeneratorSubject",
    contains = "QuantityGenerator",
    slots = c(
        "times" = "numeric",
        "subjects" = "character_or_NULL"
    )
)


#' @rdname Quant-Dev
QuantityGeneratorSubject <- function(times, subjects = NULL) {
    .QuantityGeneratorSubject(
        times = times,
        subjects = subjects
    )
}


setValidity(
    "QuantityGeneratorSubject",
    function(object) {
        if (length(object@times) != length(object@subjects)) {
            return("Length of `times` and `subjects` must be equal")
        }
        return(TRUE)
    }
)


#' @rdname as_stan_list.QuantityGenerator
#' @export
as_stan_list.QuantityGeneratorSubject <- function(object, data, ...) {
    assert_that(
        is(data, "DataJoint")
    )
    ret <- list()
    data_list <- as.list(data)
    ret[["gq_subject_index"]] <- data_list$subject_to_index[as.character(
        object@subjects
    )]
    ret[["gq_n_quant"]] <- length(object@subjects)
    ret[["gq_times"]] <- object@times

    # dummy pop indexes in order for stan code to actualy compile. In this setting
    # this matrix isn't actually used so doesn't matter what these values are
    # but don't want to have to burden individual longitudinal models with the
    # conditional logic to check if they are generating population quantities or not
    ret[["gq_long_pop_arm_index"]] <- rep(1, ret[["gq_n_quant"]])
    ret[["gq_long_pop_study_index"]] <- rep(1, ret[["gq_n_quant"]])

    # Sanity checks
    assert_that(
        length(ret[["gq_times"]]) == ret[["gq_n_quant"]],
        all(object@subjects %in% names(data_list$subject_to_index))
    )
    return(ret)
}

#' @include SurvivalModel.R
NULL

# SurvivalExponential-class ----

#' `SurvivalExponential`
#'
#' This class extends the general [`SurvivalModel`] class for using the
#' exponential survival model.
#'
#' @exportClass SurvivalExponential
.SurvivalExponential <- setClass(
    Class = "SurvivalExponential",
    contains = "SurvivalModel"
)

# SurvivalExponential-constructors ----

#' @rdname SurvivalExponential-class
#'
#' @typed lambda: Prior
#'   for the exponential rate `lambda`.
#' @typed beta: Prior
#'   for covariates coefficients `beta`.
#'
#' @export
SurvivalExponential <- function(
    lambda = prior_gamma(2, 5),
    beta = prior_normal(0, 2)
) {
    .SurvivalExponential(
        SurvivalModel(
            name = "Exponential",
            stan = StanModule("sm-exponential/model.stan"),
            parameters = ParameterList(
                Parameter(name = "sm_exp_lambda", prior = lambda, size = 1),
                Parameter(
                    name = "beta_os_cov",
                    prior = beta,
                    size = "p_os_cov_design"
                )
            )
        )
    )
}

#' @include StanModel.R
NULL

# LongitudinalModel-class ----

#' `LongitudinalModel`
#'
#' This class extends the general [`StanModel`] class to comprise the longitudinal
#' model specification.
#'
#' @exportClass LongitudinalModel
.LongitudinalModel <- setClass(
    Class = "LongitudinalModel",
    contains = "StanModel"
)

# LongitudinalModel-constructors ----

#' @rdname LongitudinalModel-class
#'
#' @inheritParams stanmodel_arguments
#'
#' @export
LongitudinalModel <- function(
    stan = StanModule(),
    parameters = ParameterList(),
    name = "<Unnamed>",
    ...
) {
    base_stan <- read_stan("base/longitudinal.stan")

    stan_full <- decorated_render(
        .x = base_stan,
        stan = add_missing_stan_blocks(as.list(stan))
    )

    .LongitudinalModel(
        StanModel(
            stan = StanModule(stan_full),
            parameters = parameters,
            name = name,
            ...
        )
    )
}

#' @export
as_print_string.LongitudinalModel <- function(object, ...) {
    string <- sprintf(
        "\n%s Longitudinal Model with parameters:\n%s\n\n",
        object@name,
        paste("   ", as_print_string(object@parameters)) |>
            paste(collapse = "\n")
    )
    return(string)
}

#' @include StanModule.R
#' @include LongitudinalModel.R
#' @include ParameterList.R
#' @include generics.R
#' @include Prior.R
NULL


#' `LinkComponent` Function Arguments
#'
#' This exists to contain all the common arguments for [`LinkComponent`] methods.
#'
#' @typed stan: StanModule
#'   Stan code.
#' @typed x: LinkComponent
#'   a link component.
#' @typed object: LinkComponent
#'   a link component.
#' @param ... Not Used.
#'
#' @name LinkComponent-Shared
#' @keywords internal
NULL


#' `LinkComponent`
#'
#' @slot stan (`StanModule`)\cr See Arguments.
#' @slot name (`character`)\cr See Arguments.
#' @slot parameters (`ParameterList`)\cr The parameter specification.
#'
#' @typed stan: StanModule
#'   Stan code. See Details.
#' @typed prior: Prior
#'   The prior for the scaling coeficient.
#' @typed key: character
#'   Link identifier. See Details.
#'
#' @details
#'
#' This object provides key information needed to construct a link contribution in the
#' survival model based on the parameters of the longitudinal model.
#'
#' Each link component defines a stan function of the longitudinal model parameters which is
#' multiplied by a model coefficient and added to the survival models hazard function.
#'
#' For full details about the specification of a `LinkComponent` please see
#' \code{vignette("extending-jmpost", package = "jmpost")}.
#'
#' @inheritParams stanmodel_arguments
#' @family LinkComponent
#' @name LinkComponent-class
#' @exportClass Link
.LinkComponent <- setClass(
    Class = "LinkComponent",
    slots = list(
        "stan" = "StanModule",
        "parameters" = "ParameterList",
        "key" = "character"
    )
)


#' @rdname LinkComponent-class
#' @export
LinkComponent <- function(stan, prior, key, ...) {
    .LinkComponent(
        stan = stan,
        key = key,
        parameters = ParameterList(Parameter(
            name = key,
            prior = prior,
            size = 1
        )),
        ...
    )
}


#' @family LinkComponent
#' @rdname getParameters
#' @export
getParameters.LinkComponent <- function(object, ...) {
    object@parameters
}


#' @family LinkComponent
#' @rdname initialValues
#' @export
initialValues.LinkComponent <- function(object, n_chains, ...) {
    initialValues(object@parameters, n_chains)
}


#' `LinkComponent` -> `StanModule`
#'
#' Converts a [`LinkComponent`] object to a [`StanModule`] object
#'
#' @inheritParams LinkComponent-Shared
#'
#' @family LinkComponent
#' @family as.StanModule
#' @export
as.StanModule.LinkComponent <- function(object, ...) {
    object@stan
}


#' `LinkComponent` -> `list`
#'
#' @inheritParams LinkComponent-Shared
#'
#' @description
#' Returns a named list where each element of the list corresponds
#' to a Stan modelling block e.g. `data`, `model`, etc.
#'
#' @family LinkComponent
#' @export
as.list.LinkComponent <- function(x, ...) {
    stan <- as.StanModule(x, ...)
    as.list(stan)
}

#' @family LinkComponent
#' @export
as_print_string.LinkComponent <- function(object, ...) {
    as_print_string(object@parameters)
}


#' @rdname show-object
#' @export
setMethod(
    f = "show",
    signature = "LinkComponent",
    definition = function(object) {
        cat(
            paste0(
                "\nLinkComponent with parameter:\n    ",
                as_print_string(object),
                "\n\n"
            )
        )
    }
)

#' @family LinkComponent
#' @export
names.LinkComponent <- function(x, ...) {
    names(x@parameters)
}

.onAttach <- function(libname, pkgname) {
    if (!is_cmdstanr_available()) {
        packageStartupMessage(
            "jmpost uses cmdstanr for compiling and sampling from models, but it does not seem to be installed.\n",
            "To install:\n",
            "install.packages(\"cmdstanr\", repos = c(\"https://stan-dev.r-universe.dev/\", getOption(\"repos\")))"
        )
    } else if (is.null(cmdstanr::cmdstan_version(error_on_NA = FALSE))) {
        possible_paths <- unique(c(
            cmdstanr::cmdstan_default_install_path(),
            Sys.getenv("CMDSTAN"),
            Sys.getenv("CMDSTAN_PATH"),
            "/root/.cmdstan",
            "~/.cmdstan"
        ))
        possible_paths <- possible_paths[dir.exists(possible_paths)]

        if (length(possible_paths)) {
            for (try_path in possible_paths) {
                new_path <- tryCatch(
                    suppressMessages(cmdstanr::set_cmdstan_path(try_path)),
                    warning = function(w) NULL,
                    error = function(e) NULL
                )
            }
            if (!is.null(new_path)) {
                packageStartupMessage("CmdStan path set to: ", new_path)
            }
        } else {
            packageStartupMessage(
                "jmpost could not identify CmdStan path. Please use cmdstanr::set_cmdstan_path()"
            )
        }
    }
    return(invisible(NULL))
}

.onLoad <- function(...) {
    set_options()
    s3_register("cmdstanr::as.CmdStanMCMC", "JointModelSamples")
}

# This only exists to silence the false positive R CMD CHECK warning about
# importing but not using the posterior package. posterior is a dependency
# of rcmdstan that we use a lot implicitly. Also we link to their documentation
# pages in ours
.never_run <- function() {
    posterior::as_draws()
}

#' @include Grid.R
#' @include generics.R
NULL


#' @rdname Grid-Dev
.GridFixed <- setClass(
    "GridFixed",
    contains = "Grid",
    slots = c(
        "subjects" = "character_or_NULL",
        "times" = "numeric_or_NULL"
    )
)

#' @rdname Grid-Functions
#' @export
GridFixed <- function(subjects = NULL, times = NULL) {
    .GridFixed(
        subjects = subjects,
        times = times
    )
}

#' @rdname Quant-Dev
#' @export
as.QuantityGenerator.GridFixed <- function(object, data, ...) {
    assert_class(data, "DataJoint")
    data_list <- as.list(data)
    subjects <- unlist(as.list(object, data = data), use.names = FALSE)

    validate_time_grid(object@times)
    subject_times <- expand.grid(
        subject = subjects,
        time = object@times,
        stringsAsFactors = FALSE
    )

    QuantityGeneratorSubject(
        times = subject_times$time,
        subjects = subject_times$subject
    )
}

#' @rdname Quant-Dev
#' @export
as.QuantityCollapser.GridFixed <- function(object, data, ...) {
    generator <- as.QuantityGenerator(object, data)
    QuantityCollapser(
        times = generator@times,
        groups = generator@subjects,
        indexes = as.list(seq_along(generator@times))
    )
}


#' @export
as.list.GridFixed <- function(x, data, ...) {
    subjects_to_list(x@subjects, data)
}

#' @rdname coalesceGridTime
#' @export
coalesceGridTime.GridFixed <- function(object, times, ...) {
    if (is.null(object@times)) {
        object <- GridFixed(
            subjects = object@subjects,
            times = times
        )
    }
    object
}

#' Promise
#'
#' Abstract class for promise objects to inherit off of
#' @aliases Promise
#' @exportClass Promise
.Promise <- setClass("Promise")


#' Promise of a `LongitudinalModel`
#'
#' An object that promises to resolve to a [`LongitudinalModel`] object.
#'
#' @exportClass PromiseLongitudinalModel
.PromiseLongitudinalModel <- setClass(
    "PromiseLongitudinalModel",
    contains = "Promise"
)

#' @rdname PromiseLongitudinalModel-class
#' @export
PromiseLongitudinalModel <- function() {
    .PromiseLongitudinalModel()
}


#' Promise of a `LinkComponent`
#'
#' An object that promises to resolve to a [`LinkComponent`] object.
#' Inheriting from [`Promise`] and [`LinkComponent`].
#'
#' @slot fun (`function`) \cr a function that returns a `LinkComponent`. See details.
#'
#' @typed fun: function
#'   a function that returns a `LinkComponent`. See details.
#' @inheritParams LinkComponent
#'
#' @details
#'
#' The `fun` slot should be a function of signature `function(prior, model)` and should return
#' a [`LinkComponent`] object. An error will be thrown if the returned [`LinkComponent`] object
#' does not have the same `key` slot value as the original `PromiseLinkComponent`.
#'
#' @exportClass PromiseLinkComponent
.PromiseLinkComponent <- setClass(
    "PromiseLinkComponent",
    contains = c("Promise", "LinkComponent"),
    slots = list(
        fun = "function"
    )
)

#' @rdname PromiseLinkComponent-class
#' @export
PromiseLinkComponent <- function(fun, prior, key) {
    .PromiseLinkComponent(
        fun = fun,
        stan = StanModule(),
        parameters = ParameterList(Parameter(
            name = key,
            prior = prior,
            size = 1
        )),
        key = key
    )
}


#' @export
as.StanModule.PromiseLinkComponent <- function(object, model, ...) {
    resolved_object <- resolvePromise(object, model = model)
    as.StanModule(resolved_object, ...)
}

#' Resolve a `PromiseLinkComponent`
#'
#' Resolves a [`PromiseLinkComponent`] object to a [`LinkComponent`] object.
#' An error will be thrown if the returned [`LinkComponent`] object
#' does not have the same `key` slot value as the original [`PromiseLinkComponent`].
#'
#' @typed object: PromiseLinkComponent
#'   the promise to resolve
#' @typed model: LongitudinalModel
#'   the model to resolve the promise with
#' @param ... Not used.
#' @typedreturn LinkComponent
#'   the resolved `LinkComponent` object
#'
#' @export
resolvePromise.PromiseLinkComponent <- function(object, model, ...) {
    x <- object@fun(
        prior = object@parameters@parameters[[1]]@prior,
        model = model
    )
    assert_that(
        is(x, "LinkComponent"),
        msg = "Resolved `PromiseLinkComponent` did not produce a `LinkComponent` object"
    )
    assert_that(
        names(object) == names(x),
        msg = paste(
            "Resolved `PromiseLinkComponent` did not produce a `LinkComponent` object",
            "with the same key as the promise"
        )
    )
    x
}

#' @include SurvivalModel.R
NULL

# SurvivalWeibullPH-class ----

#' `SurvivalWeibullPH`
#'
#' This class extends the general [`SurvivalModel`] class for using the
#' Weibull proportional hazards survival model.
#'
#' @exportClass SurvivalWeibullPH
.SurvivalWeibullPH <- setClass(
    Class = "SurvivalWeibullPH",
    contains = "SurvivalModel"
)

# SurvivalWeibullPH-constructors ----

#' @rdname SurvivalWeibullPH-class
#'
#' @typed lambda: Prior
#'   for the scale `lambda`.
#' @typed gamma: Prior
#'   for the shape `gamma`.
#' @typed beta: Prior
#'   for covariates coefficients `beta`.
#'
#' @export
SurvivalWeibullPH <- function(
    lambda = prior_gamma(2, 0.5),
    gamma = prior_gamma(2, 0.5),
    beta = prior_normal(0, 2)
) {
    lambda <- set_limits(lambda, lower = 0)
    gamma <- set_limits(gamma, lower = 0)

    .SurvivalWeibullPH(
        SurvivalModel(
            name = "Weibull-PH",
            stan = StanModule(x = "sm-weibull-ph/model.stan"),
            parameters = ParameterList(
                Parameter(
                    name = "sm_weibull_ph_lambda",
                    prior = lambda,
                    size = 1
                ),
                Parameter(
                    name = "sm_weibull_ph_gamma",
                    prior = gamma,
                    size = 1
                ),
                Parameter(
                    name = "beta_os_cov",
                    prior = beta,
                    size = "p_os_cov_design"
                )
            )
        )
    )
}

#' Define Simulation Group
#'
#' Specifies a simulation group to be used by [`SimJointData()`].
#'
#' @typed n: numeric
#'   number of subjects in the group.
#' @typed arm: character
#'   treatment arm.
#' @typed study: character
#'   study name.
#'
#' @slot n (`numeric`)\cr See arguments.
#' @slot arm (`character`)\cr See arguments.
#' @slot study (`character`)\cr See arguments.
#'
#' @examples
#' SimGroup(n = 50, arm = "Arm-A", study = "Study-1")
#' @name SimGroup-class
#' @exportClass SimGroup
.SimGroup <- setClass(
    "SimGroup",
    slots = c(
        n = "numeric",
        arm = "character",
        study = "character"
    )
)

#' @export
#' @rdname SimGroup-class
SimGroup <- function(n, arm, study) {
    .SimGroup(
        n = n,
        arm = arm,
        study = study
    )
}


setValidity(
    "SimGroup",
    function(object) {
        if (length(object@n) != 1) {
            return("`n` must be a length 1 integer")
        }
        if (length(object@arm) != 1) {
            return("`arm` must be a length 1 string")
        }
        if (length(object@study) != 1) {
            return("`study` must be a length 1 string")
        }
        if (any(object@n < 1) | any(object@n %% 1 != 0)) {
            return("`n` must be positive integer")
        }
        return(TRUE)
    }
)

1		#' @include Grid.R
2		#' @include generics.R
3		NULL
4
5
6		#' @rdname Grid-Dev
7		.GridPrediction <- setClass(
8		"GridPrediction",
9		contains = "Grid",
10		slots = c(
11		"times" = "numeric_or_NULL",
12		"newdata" = "data.frame",
13		"params" = "list"
14		)
15		)
16		#' @rdname Grid-Functions
17		#' @export
18		GridPrediction <- function(times = NULL, newdata, params = list()) {
19	7x	.GridPrediction(
20	7x	times = times,
21	7x	params = params,
22	7x	newdata = newdata
23		)
24		}
25		setValidity(
26		"GridPrediction",
27		function(object) {
28		for (param in names(object@params)) {
29		if (length(object@params[[param]]) != 1) {
30		return(sprintf("Parameter '%s' must be length 1", param))
31		}
32		}
33		if (length(object@params) != length(names(object@params))) {
34		return("All elements of `params` must be named")
35		}
36		if (!is.null(object@newdata[["..new_subject.."]])) {
37		return(
38		"`newdata` must not contain a column named '..new_subject..'"
39		)
40		}
41		return(TRUE)
42		}
43		)
44
45
46		#' @rdname Quant-Dev
47		#' @export
48		as.QuantityGenerator.GridPrediction <- function(object, data, ...) {
49	6x	assert_class(data, "DataJoint")
50	6x	data_list <- as.list(data)
51	6x	validate_time_grid(object@times)
52
53	6x	n_times <- length(object@times)
54	6x	n_obs <- nrow(object@newdata)
55	6x	newdata <- object@newdata
56	6x	newdata[["..new_subject.."]] <- sprintf(
57	6x	"new_subject_%i",
58	6x	seq_len(nrow(newdata))
59		)
60
61	6x	QuantityGeneratorPrediction(
62	6x	times = rep(object@times, each = n_obs),
63	6x	newdata = replicate(newdata, n = n_times, simplify = FALSE) \|>
64	6x	dplyr::bind_rows(),
65	6x	params = object@params
66		)
67		}
68
69		#' @rdname Quant-Dev
70		#' @export
71		as.QuantityCollapser.GridPrediction <- function(object, data, ...) {
72	2x	assert_class(data, "DataJoint")
73	2x	data_list <- as.list(data)
74	2x	generator <- as.QuantityGenerator(object, data)
75	2x	QuantityCollapser(
76	2x	times = generator@times,
77	2x	groups = generator@newdata[["..new_subject.."]],
78	2x	indexes = as.list(seq_along(generator@times))
79		)
80		}
81
82
83		#' @export
84		as.list.GridPrediction <- function(x, data, ...) {
85	!	stop("`as.list()` is not implemented for `GridPrediction` objects")
86		}
87
88
89		#' @rdname coalesceGridTime
90		#' @export
91		coalesceGridTime.GridPrediction <- function(object, times, ...) {
92	4x	if (is.null(object@times)) {
93	!	object <- GridPrediction(
94	!	times = times,
95	!	newdata = object@newdata,
96	!	params = object@params
97		)
98		}
99	4x	object
100		}

1		#' @include Grid.R
2		#' @include generics.R
3		NULL
4
5		#' @rdname Grid-Dev
6		.GridEvent <- setClass(
7		"GridEvent",
8		contains = "Grid",
9		slots = c(
10		"subjects" = "character_or_NULL"
11		)
12		)
13
14
15		#' @rdname Grid-Functions
16		#' @export
17		GridEvent <- function(subjects = NULL) {
18	1x	.GridEvent(
19	1x	subjects = subjects
20		)
21		}
22
23		#' @rdname Quant-Dev
24		#' @export
25		as.QuantityGenerator.GridEvent <- function(object, data, ...) {
26	3x	assert_class(data, "DataJoint")
27	3x	assert_that(
28	3x	!is.null(data@survival),
29	3x	msg = "Survival data must have been provided to `DataJoint()` in order to use `GridEvent()`"
30		)
31	2x	data_list <- as.list(data)
32	2x	subjects <- unlist(as.list(object, data = data), use.names = FALSE)
33	2x	event_times <- data_list$event_times[data_list$subject_to_index[subjects]]
34	2x	QuantityGeneratorSubject(
35	2x	times = event_times,
36	2x	subjects = subjects
37		)
38		}
39
40		#' @rdname Quant-Dev
41		#' @export
42		as.QuantityCollapser.GridEvent <- function(object, data, ...) {
43	1x	generator <- as.QuantityGenerator(object, data)
44	1x	QuantityCollapser(
45	1x	times = generator@times,
46	1x	groups = generator@subjects,
47	1x	indexes = as.list(seq_along(generator@times))
48		)
49		}
50
51		#' @export
52		as.list.GridEvent <- function(x, data, ...) {
53	2x	subjects_to_list(x@subjects, data)
54		}

1		#' @include Grid.R
2		#' @include generics.R
3		NULL
4
5
6		#' @rdname Grid-Dev
7		.GridManual <- setClass(
8		"GridManual",
9		contains = "Grid",
10		slots = c(
11		"spec" = "list"
12		)
13		)
14
15
16		#' @rdname Grid-Functions
17		#' @export
18		GridManual <- function(spec) {
19	8x	.GridManual(
20	8x	spec = spec
21		)
22		}
23
24
25		setValidity(
26		"GridManual",
27		function(object) {
28		subject_names <- names(object@spec)
29		subject_names_valid <- subject_names[
30		!is.na(subject_names) & subject_names != ""
31		]
32		if (length(subject_names_valid) != length(object@spec)) {
33		return("Each element of `subjects` must be named")
34		}
35		for (times in object@spec) {
36		if (!is.numeric(times)) {
37		return("Each element of `spec` must be a numeric vector")
38		}
39		if (length(times) != length(unique(times))) {
40		return("Each time vector per subject must be unique")
41		}
42		}
43		return(TRUE)
44		}
45		)
46
47
48		#' @rdname Quant-Dev
49		#' @export
50		as.QuantityGenerator.GridManual <- function(object, data, ...) {
51	14x	assert_class(data, "DataJoint")
52	14x	data_list <- as.list(data)
53	14x	assert_that(
54	14x	all(names(object@spec) %in% names(data_list$subject_to_index)),
55	14x	msg = "All subject names must be in the `DataSubject` object"
56		)
57	14x	lens <- vapply(object@spec, length, numeric(1))
58	14x	QuantityGeneratorSubject(
59	14x	times = unlist(object@spec, use.names = FALSE),
60	14x	subjects = rep(names(object@spec), lens)
61		)
62		}
63
64
65		#' @rdname Quant-Dev
66		#' @export
67		as.QuantityCollapser.GridManual <- function(object, data, ...) {
68	6x	generator <- as.QuantityGenerator(object, data)
69	6x	QuantityCollapser(
70	6x	times = generator@times,
71	6x	groups = generator@subjects,
72	6x	indexes = as.list(seq_along(generator@times))
73		)
74		}
75
76
77		#' @export
78		as.list.GridManual <- function(x, data, ...) {
79	!	subs <- as.list(names(x@spec))
80	!	names(subs) <- names(x@spec)
81	!	subs
82		}

1		#' @include generics.R
2		#' @include Grid.R
3		NULL
4
5		#' @rdname Quant-Dev
6		.QuantityGeneratorPrediction <- setClass(
7		"QuantityGeneratorPrediction",
8		contains = "QuantityGenerator",
9		slots = c(
10		"times" = "numeric",
11		"newdata" = "data.frame",
12		"params" = "list"
13		)
14		)
15
16
17		#' @rdname Quant-Dev
18		QuantityGeneratorPrediction <- function(times, newdata = NULL, params = NULL) {
19	6x	.QuantityGeneratorPrediction(
20	6x	times = times,
21	6x	newdata = newdata,
22	6x	params = params
23		)
24		}
25		setValidity(
26		"QuantityGeneratorPrediction",
27		function(object) {
28		if (length(object@times) != nrow(object@newdata)) {
29		return("Length of `times` and `newdata` must be equal")
30		}
31		return(TRUE)
32		}
33		)
34
35
36		#' @rdname as_stan_list.QuantityGenerator
37		#' @export
38		as_stan_list.QuantityGeneratorPrediction <- function(object, data, model, ...) {
39	3x	assert_that(
40	3x	is(data, "DataJoint")
41		)
42	3x	ret <- list()
43	3x	data_list <- as_stan_list(data)
44
45	3x	ret[["gq_times"]] <- object@times
46	3x	ret[["gq_n_quant"]] <- length(object@times)
47
48		# Get a list of which longutidunal parameters need to be defined based
49		# on the selected longitudinal model
50	3x	par_names <- getPredictionNames(model@longitudinal)
51	3x	for (nam in par_names) {
52	8x	assert_that(
53	8x	nam %in% names(object@params),
54	8x	msg = sprintf("Parameter '%s' not found in `params`", nam)
55		)
56	8x	assert_that(
57	8x	is.numeric(object@params[[nam]]),
58	8x	msg = sprintf("Parameter '%s' must be numeric", nam)
59		)
60	8x	assert_that(
61	8x	length(object@params[[nam]]) == 1,
62	8x	msg = sprintf("Parameter '%s' must be length 1", nam)
63		)
64		}
65
66	3x	par_vals <- object@params[par_names]
67	3x	if (length(par_vals) == 0) {
68	1x	par_vals <- 0
69	1x	par_names <- "null_model"
70		}
71
72	3x	ret[["gq_n_par"]] <- length(par_names)
73
74		# Replicate the longitudinal parameters so the same parameter values are used
75		# for all observations that are being predicted
76	3x	ret[["gq_link_function_inputs"]] <- matrix(
77	3x	rep(unlist(par_vals), each = ret[["gq_n_quant"]]),
78	3x	ncol = ret[["gq_n_par"]],
79	3x	nrow = ret[["gq_n_quant"]]
80		)
81
82		# Create design matrix from new data ensuring that it has the same
83		# structure as the original design matrix
84	3x	ret[["gq_os_cov_design"]] <- mirror_design_matrix(
85	3x	data@survival,
86	3x	object@newdata
87		)
88
89		# dummy pop indexes in order for stan code to actualy compile. In this setting
90		# this matrix isn't actually used so doesn't matter what these values are
91		# but don't want to have to burden individual longitudinal models with the
92		# conditional logic to check if they are generating population quantities or not
93	2x	ret[["gq_long_pop_arm_index"]] <- rep(1, ret[["gq_n_quant"]])
94	2x	ret[["gq_long_pop_study_index"]] <- rep(1, ret[["gq_n_quant"]])
95
96		# Sanity checks
97	2x	assert_that(
98	2x	nrow(ret[["gq_os_cov_design"]]) == ret[["gq_n_quant"]],
99	2x	ncol(ret[["gq_os_cov_design"]]) == data_list[["p_os_cov_design"]],
100	2x	all(!is.na(ret[["gq_link_function_inputs"]]))
101		)
102
103	2x	return(ret)
104		}

1		#' @include Grid.R
2		#' @include GridFixed.R
3		#' @include generics.R
4		NULL
5
6		#' @rdname Grid-Dev
7		.GridGrouped <- setClass(
8		"GridGrouped",
9		contains = "Grid",
10		slots = c(
11		"groups" = "list",
12		"times" = "numeric_or_NULL"
13		)
14		)
15
16		#' @rdname Grid-Functions
17		#' @export
18		GridGrouped <- function(groups, times = NULL) {
19	13x	.GridGrouped(
20	13x	groups = groups,
21	13x	times = times
22		)
23		}
24
25
26		setValidity(
27		"GridGrouped",
28		function(object) {
29		if (!all(vapply(object@groups, is.character, logical(1)))) {
30		return("Each element of `groups` must be a character vector")
31		}
32		gnames <- names(object@groups)
33		gnames <- gnames[!is.na(gnames) & gnames != ""]
34		if (length(gnames) != length(object@groups)) {
35		return("Each element of `groups` must be named")
36		}
37		return(TRUE)
38		}
39		)
40
41
42		#' @rdname Quant-Dev
43		#' @export
44		as.QuantityGenerator.GridGrouped <- function(object, data, ...) {
45	17x	assert_class(data, "DataJoint")
46	17x	data_list <- as.list(data)
47	17x	subjects_unique <- unique(unlist(object@groups))
48	17x	assert_that(
49	17x	all(subjects_unique %in% names(data_list$subject_to_index))
50		)
51	17x	as.QuantityGenerator(
52	17x	GridFixed(
53	17x	times = object@times,
54	17x	subjects = subjects_unique
55		),
56	17x	data = data
57		)
58		}
59
60
61		#' @rdname Quant-Dev
62		#' @export
63		as.QuantityCollapser.GridGrouped <- function(object, data, ...) {
64	8x	assert_class(data, "DataJoint")
65	8x	data_list <- as.list(data)
66	8x	assert_that(
67	8x	all(
68	8x	unique(unlist(object@groups)) %in% names(data_list$subject_to_index)
69		)
70		)
71
72	8x	validate_time_grid(object@times)
73
74	8x	group_grid <- expand.grid(
75	8x	group = names(object@groups),
76	8x	time = object@times,
77	8x	stringsAsFactors = FALSE
78		)
79
80	8x	generator <- as.QuantityGenerator(object, data)
81
82	8x	select_indexes <- mapply(
83	8x	function(group, time) {
84	490x	correct_subject <- generator@subjects %in% object@groups[[group]]
85	490x	correct_time <- generator@times == time
86	490x	seq_along(correct_time)[correct_subject & correct_time]
87		},
88	8x	group_grid$group,
89	8x	group_grid$time,
90	8x	SIMPLIFY = FALSE
91		)
92	8x	names(select_indexes) <- NULL
93
94	8x	QuantityCollapser(
95	8x	times = group_grid$time,
96	8x	groups = group_grid$group,
97	8x	indexes = select_indexes
98		)
99		}
100
101		#' @export
102		as.list.GridGrouped <- function(x, ...) {
103	1x	x@groups
104		}
105
106		#' @rdname coalesceGridTime
107		#' @export
108		coalesceGridTime.GridGrouped <- function(object, times, ...) {
109	10x	if (is.null(object@times)) {
110	2x	object <- GridGrouped(
111	2x	groups = object@groups,
112	2x	times = times
113		)
114		}
115	10x	object
116		}

1		#' @include SurvivalModel.R
2		NULL
3
4
5		#' `SurvivalGamma`
6		#'
7		#' This class extends the general [`SurvivalModel`] class for using the
8		#' Gamma survival model.
9		#'
10		#' @exportClass SurvivalGamma
11		.SurvivalGamma <- setClass(
12		Class = "SurvivalGamma",
13		contains = "SurvivalModel"
14		)
15
16		# SurvivalGamma-constructors ----
17
18		#' @rdname SurvivalGamma-class
19		#'
20		#' @typed k: Prior
21		#' for the shape `k`.
22		#' @typed theta: Prior
23		#' for the scale `theta`.
24		#' @typed beta: Prior
25		#' for covariates coefficients `beta`.
26		#'
27		#' @export
28		SurvivalGamma <- function(
29		k = prior_gamma(2, 0.5),
30		theta = prior_gamma(2, 0.5),
31		beta = prior_normal(0, 2)
32		) {
33	4x	k <- set_limits(k, lower = 0)
34	4x	theta <- set_limits(theta, lower = 0)
35
36	4x	.SurvivalGamma(
37	4x	SurvivalModel(
38	4x	name = "Gamma",
39	4x	stan = StanModule(x = "sm-gamma/model.stan"),
40	4x	parameters = ParameterList(
41	4x	Parameter(name = "sm_gamma_k", prior = k, size = 1),
42	4x	Parameter(name = "sm_gamma_theta", prior = theta, size = 1),
43	4x	Parameter(
44	4x	name = "beta_os_cov",
45	4x	prior = beta,
46	4x	size = "p_os_cov_design"
47		)
48		)
49		)
50		)
51		}

1		#' Re-used documentation for Brier Score components
2		#'
3		#' @typed t: numeric
4		#' timepoints to calculate the desired quantity at.
5		#' @typed times: numeric
6		#' observed times.
7		#' @typed events: numeric
8		#' event indicator for `times`. Either 1 for an event or 0 for censor.
9		#' @typed event_offset: logical
10		#' If `TRUE` then \eqn{G(T_i)} is evaluated at \eqn{G(T_i-)}.
11		#' Setting this as `TRUE` mirrors the implementation of the `{pec}` package.
12		#' @typed maintain_cen_order: logical
13		#' If `TRUE` then, in the case of ties,
14		#' censor times are always considered
15		#' to have occurred after the event times when calculating the "reverse Kaplan-Meier" for the
16		#' IPCW estimates. Setting this to `TRUE` mirrors the implementation of the `{prodlim}`
17		#' package.
18		#' @param ... not used.
19		#'
20		#' @name Brier-Score-Shared
21		#' @keywords internal
22		NULL
23
24
25		#' Reverse Kaplan-Meier
26		#'
27		#' @inheritParams Brier-Score-Shared
28		#' @description
29		#' Calculates the survival estimates of the censoring distribution
30		#' using the Kaplan-Meier estimate.
31		#' This is primarily used in the calculation of the IPCW estimates.
32		#'
33		#' @details
34		#' With regards to ties between censor and event times; the standard
35		#' approach is to regard events as occurring before censors. However,
36		#' when modelling the censoring distribution we are regarding the
37		#' censors as "events" so which should come first in the case of ties?
38		#'
39		#' The `reverse_km_event_first()` function maintains the rule
40		#' that events always come first even if we are regarding the censors
41		#' as "events". This matches the implementation of
42		#' `prodlim::prodlim(..., reverse = TRUE)`.
43		#'
44		#' The `reverse_km_cen_first()` function provides the alternative
45		#' implementation assuming that in the case of ties the censor "events"
46		#' come before the event "censors". This is essentially a thin wrapper
47		#' around `survival::survfit(Surv(time, 1 - event), ...)`
48		#'
49		#' @name reverse_km
50		#' @keywords internal
51		reverse_km_event_first <- function(t, times, events) {
52	9x	assert_numeric(t, any.missing = FALSE, finite = TRUE)
53	9x	assert_numeric(times, any.missing = FALSE, finite = TRUE)
54	9x	assert_numeric(events, any.missing = FALSE, finite = TRUE)
55	9x	assert_that(
56	9x	length(times) == length(events),
57	9x	all(events == 1 \| events == 0)
58		)
59	9x	events_cen <- 1 - events
60	9x	ord <- order(times, events_cen)
61	9x	times <- times[ord]
62	9x	events <- events[ord]
63	9x	events_cen <- events_cen[ord]
64	9x	cs_events <- cumsum(events)
65	9x	cs_censor <- cumsum(events_cen)
66
67	9x	g_times <- unique(times)
68	9x	g_n_events_cen <- tapply(events_cen, times, sum)
69	9x	g_cs_events_cen <- tapply(cs_censor, times, max)
70	9x	g_cs_events <- tapply(cs_events, times, max)
71	9x	g_is_cen <- tapply(events_cen, times, max)
72
73	9x	nrisk <- length(times) - g_cs_events - g_cs_events_cen + g_n_events_cen
74	9x	surv_interval <- 1 - g_n_events_cen / nrisk
75	9x	surv_interval <- ifelse(nrisk == 0, 1, surv_interval)
76	9x	surv <- cumprod(surv_interval)
77
78	9x	ct <- g_times[which(g_is_cen == 1)]
79	9x	sv <- surv[which(g_is_cen == 1)]
80
81	9x	names(surv) <- NULL
82	9x	names(ct) <- NULL
83	9x	names(sv) <- NULL
84	9x	list(
85	9x	t = t,
86	9x	surv = c(1, sv)[findInterval(t, ct) + 1]
87		)
88		}
89
90
91		#' @rdname reverse_km
92		reverse_km_cen_first <- function(t, times, events) {
93	1x	assert_numeric(t, any.missing = FALSE, finite = TRUE)
94	1x	assert_numeric(times, any.missing = FALSE, finite = TRUE)
95	1x	assert_numeric(events, any.missing = FALSE, finite = TRUE)
96	1x	assert_that(
97	1x	length(times) == length(events),
98	1x	all(events == 1 \| events == 0)
99		)
100	1x	dat <- data.frame(
101	1x	times = times,
102	1x	events = events,
103	1x	cen_events = 1 - events
104		)
105	1x	mod <- survival::survfit(
106	1x	survival::Surv(times, cen_events) ~ 1,
107	1x	data = dat
108		)
109	1x	preds <- summary(mod, times = t[order(t)], extend = TRUE)$surv
110
111	1x	assert_that(
112	1x	length(preds) == length(t)
113		)
114	1x	list(
115	1x	t = t,
116	1x	surv = preds[match_order(t)]
117		)
118		}
119
120		#' Match Order
121		#'
122		#' @typed x: numeric
123		#' a vector for which we want to generate an index so other
124		#' vectors can be put into the same sort order
125		#'
126		#' Assuming we have a vector that is sorted then this function
127		#' will return the index vector to convert that sorted vector
128		#' into the same sort order as the input vector `x`.
129		#' For example let `x = 8, 7, 9 , 7`. If sorted we would get
130		#' `x_sort = 7, 7, 8, 9`. So in order to convert `x_sort`
131		#' back into `x` we'd need an index vector of `3, 1, 4, 2`.
132		#' This function is used to determine that corresponding
133		#' index vector for an arbitrarily sorted vector `x`.
134		#'
135		#' There is no specific handling of ties. It is assuming that in the case
136		#' of ties for `x` that the vector you are re-indexing also has tied values
137		#' thus the specific tied element selection does not matter.
138		#' @keywords internal
139		match_order <- function(x) {
140	2x	order(order(x))
141		}
142
143
144		#' Brier Score
145		#'
146		#' @inheritParams Brier-Score-Shared
147		#'
148		#' @description
149		#' Implements the Brier Score as detailed in \insertCite{blanche2015}{jmpost}
150		#'
151		#' @details
152		#' - `bs_get_squared_dist()` - implements the squared distance part
153		#' of the formula.
154		#' - `bs_get_weights()` - implements the IPCW weighting
155		#'
156		#' @references
157		#' \insertAllCited{}
158		#'
159		#' @keywords internal
160		brier_score <- function(
161		t,
162		times,
163		events,
164		pred_mat,
165		maintain_cen_order = TRUE,
166		event_offset = TRUE
167		) {
168	4x	square_diff_mat <- bs_get_squared_dist(
169	4x	t = t,
170	4x	times = times,
171	4x	events = events,
172	4x	pred_mat = pred_mat
173		)
174
175	4x	weight_mat <- bs_get_weights(
176	4x	t = t,
177	4x	times = times,
178	4x	events = events,
179	4x	event_offset = event_offset,
180	4x	maintain_cen_order = maintain_cen_order
181		)
182
183		# the following is a computational shortcut for diag(A %*% B)
184		# as we don't want to compute the off-diagonal entries of the
185		# matrix multiplication
186	4x	x <- colSums(weight_mat * square_diff_mat)
187	4x	names(x) <- t
188	4x	x / length(times)
189		}
190
191
192		#' @rdname brier_score
193		bs_get_squared_dist <- function(t, times, events, pred_mat) {
194	5x	assert_numeric(
195	5x	times,
196	5x	finite = TRUE,
197	5x	any.missing = FALSE
198		)
199	5x	assert_numeric(
200	5x	t,
201	5x	finite = TRUE,
202	5x	any.missing = FALSE
203		)
204	5x	assert_numeric(
205	5x	events,
206	5x	finite = TRUE,
207	5x	any.missing = FALSE,
208	5x	lower = 0,
209	5x	upper = 1
210		)
211	5x	assert_matrix(
212	5x	pred_mat,
213	5x	any.missing = FALSE,
214	5x	nrows = length(times),
215	5x	ncols = length(t)
216		)
217	5x	assert_that(
218	5x	length(events) == length(times)
219		)
220
221	5x	expected_mat <- mapply(
222	5x	\(ti, event) (ti <= t) * event * 1,
223	5x	ti = times,
224	5x	event = events,
225	5x	SIMPLIFY = FALSE
226		) \|>
227	5x	unlist() \|>
228	5x	matrix(ncol = length(t), byrow = TRUE)
229
230	5x	assert_that(
231	5x	nrow(pred_mat) == nrow(expected_mat),
232	5x	ncol(pred_mat) == ncol(expected_mat)
233		)
234
235	5x	(expected_mat - pred_mat)^2
236		}
237
238
239		#' @rdname brier_score
240		bs_get_weights <- function(
241		t,
242		times,
243		events,
244		event_offset = TRUE,
245		maintain_cen_order = TRUE
246		) {
247	5x	assert_numeric(
248	5x	times,
249	5x	finite = TRUE,
250	5x	any.missing = FALSE
251		)
252	5x	assert_numeric(
253	5x	t,
254	5x	finite = TRUE,
255	5x	any.missing = FALSE
256		)
257	5x	assert_numeric(
258	5x	events,
259	5x	finite = TRUE,
260	5x	any.missing = FALSE,
261	5x	lower = 0,
262	5x	upper = 1
263		)
264	5x	assert_flag(event_offset, na.ok = FALSE, null.ok = FALSE)
265	5x	assert_flag(maintain_cen_order, na.ok = FALSE, null.ok = FALSE)
266	5x	n_col <- length(t)
267	5x	n_row <- length(times)
268
269	5x	reverse_km <- if (maintain_cen_order) {
270	5x	reverse_km_event_first
271		} else {
272	!	reverse_km_cen_first
273		}
274	5x	offset <- if (event_offset) -.Machine$double.eps^(1 / 2) else 0
275
276	5x	censor_dist_t <- reverse_km(t, times, events)
277	5x	weight_mat_t <- 1 /
278	5x	matrix(
279	5x	rep(censor_dist_t$surv, n_row),
280	5x	nrow = n_row,
281	5x	byrow = TRUE
282		)
283
284	5x	censor_dist_ti <- reverse_km(times + offset, times, events)
285	5x	weight_mat_ti <- 1 /
286	5x	matrix(
287	5x	rep(censor_dist_ti$surv, n_col),
288	5x	nrow = n_row
289		)
290
291	5x	indicator_mat_t <- mapply(
292	5x	\(ti) (ti > t) * 1,
293	5x	ti = times,
294	5x	SIMPLIFY = FALSE
295		) \|>
296	5x	unlist() \|>
297	5x	matrix(ncol = n_col, byrow = TRUE)
298
299	5x	indicator_mat_ti <- mapply(
300	5x	\(ti, event) (ti <= t) * event * 1,
301	5x	ti = times,
302	5x	event = events,
303	5x	SIMPLIFY = FALSE
304		) \|>
305	5x	unlist() \|>
306	5x	matrix(ncol = n_col, byrow = TRUE)
307
308	5x	assert_that(
309	5x	all(indicator_mat_t + indicator_mat_ti <= 1)
310		)
311
312	5x	weight_mat_t[indicator_mat_t == 0] <- 0
313	5x	weight_mat_ti[indicator_mat_ti == 0] <- 0
314
315	5x	(weight_mat_t + weight_mat_ti)
316		}

1		#' @include SimLongitudinal.R
2		#' @include generics.R
3		NULL
4
5		#' Simulate Longitudinal Data from a GSF Model
6		#'
7		#' @typed times: numeric
8		#' the times to generate observations at.
9		#' @typed sigma: number
10		#' the variance of the longitudinal values.
11		#' @typed mu_s: numeric
12		#' the mean shrinkage rates.
13		#' @typed mu_g: numeric
14		#' the mean growth rates.
15		#' @typed mu_b: numeric
16		#' the mean baseline values.
17		#' @typed mu_phi: numeric
18		#' the mean proportion of cells affected by the treatment
19		#' @typed omega_b: number
20		#' the baseline value standard deviation.
21		#' @typed omega_s: number
22		#' the shrinkage rate standard deviation.
23		#' @typed omega_g: number
24		#' the growth rate standard deviation.
25		#' @typed omega_phi: number
26		#' for the standard deviation of the proportion of cells
27		#' affected by the treatment `omega_phi`.
28		#' @typed link_dsld: number
29		#' the link coefficient for the derivative contribution.
30		#' @typed link_ttg: number
31		#' the link coefficient for the time-to-growth contribution.
32		#' @typed link_identity: number
33		#' the link coefficient for the SLD Identity contribution.
34		#' @typed link_growth: number
35		#' the link coefficient for the log-growth parameter contribution.
36		#' @typed link_shrinkage: number
37		#' the link coefficient for the log-shrinkage parameter contribution.
38		#' @typed scaled_variance: logical
39		#' whether the variance should be scaled by the expected value
40		#' (see the "Statistical Specifications" vignette for more details)
41		#'
42		#' @slot sigma (`numeric`)\cr See arguments.
43		#' @slot mu_s (`numeric`)\cr See arguments.
44		#' @slot mu_g (`numeric`)\cr See arguments.
45		#' @slot mu_b (`numeric`)\cr See arguments.
46		#' @slot mu_phi (`numeric`)\cr See arguments.
47		#' @slot omega_b (`numeric`)\cr See arguments.
48		#' @slot omega_s (`numeric`)\cr See arguments.
49		#' @slot omega_g (`numeric`)\cr See arguments.
50		#' @slot omega_phi (`numeric`)\cr See arguments.
51		#' @slot link_dsld (`numeric`)\cr See arguments.
52		#' @slot link_ttg (`numeric`)\cr See arguments.
53		#' @slot link_identity (`numeric`)\cr See arguments.
54		#' @slot link_growth (`numeric`)\cr See arguments.
55		#' @slot link_shrinkage (`numeric`)\cr See arguments.
56		#' @slot scaled_variance (`numeric`)\cr See arguments.
57		#' @family SimLongitudinal
58		#' @name SimLongitudinalGSF-class
59		#' @exportClass SimLongitudinalGSF
60		.SimLongitudinalGSF <- setClass(
61		"SimLongitudinalGSF",
62		contains = "SimLongitudinal",
63		slots = c(
64		sigma = "numeric",
65		mu_s = "numeric",
66		mu_g = "numeric",
67		mu_b = "numeric",
68		mu_phi = "numeric",
69		omega_b = "numeric",
70		omega_s = "numeric",
71		omega_g = "numeric",
72		omega_phi = "numeric",
73		link_dsld = "numeric",
74		link_ttg = "numeric",
75		link_identity = "numeric",
76		link_growth = "numeric",
77		link_shrinkage = "numeric",
78		scaled_variance = "logical"
79		)
80		)
81
82		#' @rdname SimLongitudinalGSF-class
83		#' @export
84		SimLongitudinalGSF <- function(
85		times = c(-100, -50, 0, 50, 100, 150, 250, 350, 450, 550) / 365,
86		sigma = 0.01,
87		mu_s = log(c(0.6, 0.4)),
88		mu_g = log(c(0.25, 0.35)),
89		mu_b = log(60),
90		mu_phi = qlogis(c(0.4, 0.6)),
91		omega_b = 0.2,
92		omega_s = 0.2,
93		omega_g = 0.2,
94		omega_phi = 0.2,
95		link_dsld = 0,
96		link_ttg = 0,
97		link_identity = 0,
98		link_growth = 0,
99		link_shrinkage = 0,
100		scaled_variance = TRUE
101		) {
102	11x	if (length(omega_b) == 1) {
103	11x	omega_b <- rep(omega_b, length(mu_b))
104		}
105	11x	if (length(omega_s) == 1) {
106	11x	omega_s <- rep(omega_s, length(mu_s))
107		}
108	11x	if (length(omega_g) == 1) {
109	11x	omega_g <- rep(omega_g, length(mu_g))
110		}
111	11x	if (length(omega_phi) == 1) {
112	11x	omega_phi <- rep(omega_phi, length(mu_phi))
113		}
114
115	11x	.SimLongitudinalGSF(
116	11x	times = times,
117	11x	sigma = sigma,
118	11x	mu_s = mu_s,
119	11x	mu_g = mu_g,
120	11x	mu_b = mu_b,
121	11x	mu_phi = mu_phi,
122	11x	omega_b = omega_b,
123	11x	omega_s = omega_s,
124	11x	omega_g = omega_g,
125	11x	omega_phi = omega_phi,
126	11x	link_dsld = link_dsld,
127	11x	link_ttg = link_ttg,
128	11x	link_identity = link_identity,
129	11x	link_growth = link_growth,
130	11x	link_shrinkage = link_shrinkage,
131	11x	scaled_variance = scaled_variance
132		)
133		}
134
135
136		setValidity(
137		"SimLongitudinalGSF",
138		function(object) {
139		par_lengths <- c(
140		length(object@mu_s),
141		length(object@mu_g),
142		length(object@mu_phi)
143		)
144		if (length(unique(par_lengths)) != 1) {
145		return(
146		"The parameters `mu_s`, `mu_g` and `mu_phi` must have the same length."
147		)
148		}
149
150		pairs <- list(
151		"omega_b" = "mu_b",
152		"omega_s" = "mu_s",
153		"omega_g" = "mu_g",
154		"omega_phi" = "mu_phi"
155		)
156		for (i in seq_along(pairs)) {
157		omega <- slot(object, names(pairs)[[i]])
158		mu <- slot(object, pairs[[i]])
159		if (!(length(omega) == length(mu))) {
160		return(
161		sprintf(
162		"`%s` must be length 1 or the same length as `%s`",
163		omega,
164		mu
165		)
166		)
167		}
168		}
169
170		len_1_pars <- c(
171		"sigma",
172		"link_dsld",
173		"link_ttg",
174		"link_identity",
175		"link_growth",
176		"link_shrinkage"
177		)
178		for (par in len_1_pars) {
179		if (length(slot(object, par)) != 1) {
180		return(sprintf(
181		"The `%s` parameter must be a length 1 numeric.",
182		par
183		))
184		}
185		}
186
187		return(TRUE)
188		}
189		)
190
191		#' @rdname as_print_string
192		#' @exportS3Method NULL
193		as_print_string.SimLongitudinalGSF <- function(object, ...) {
194	1x	return("SimLongitudinalGSF")
195		}
196
197		#' @rdname sampleObservations
198		#' @export
199		sampleObservations.SimLongitudinalGSF <- function(object, times_df) {
200	19x	times_df \|>
201	19x	dplyr::mutate(
202	19x	mu_sld = gsf_sld(
203	19x	.data$time,
204	19x	.data$psi_b,
205	19x	.data$psi_s,
206	19x	.data$psi_g,
207	19x	.data$psi_phi
208		),
209	19x	dsld = gsf_dsld(
210	19x	.data$time,
211	19x	.data$psi_b,
212	19x	.data$psi_s,
213	19x	.data$psi_g,
214	19x	.data$psi_phi
215		),
216	19x	ttg = gsf_ttg(
217	19x	.data$time,
218	19x	.data$psi_b,
219	19x	.data$psi_s,
220	19x	.data$psi_g,
221	19x	.data$psi_phi
222		),
223	19x	sld_sd = ifelse(
224	19x	object@scaled_variance,
225	19x	.data$mu_sld * object@sigma,
226	19x	object@sigma
227		),
228	19x	sld = stats::rnorm(dplyr::n(), .data$mu_sld, .data$sld_sd),
229	19x	log_haz_link = (object@link_dsld * .data$dsld) +
230	19x	(object@link_ttg * .data$ttg) +
231	19x	(object@link_identity * .data$mu_sld) +
232	19x	(object@link_growth * log(.data$psi_g)) +
233	19x	(object@link_shrinkage * log(.data$psi_s))
234		)
235		}
236
237
238		#' @rdname sampleSubjects
239		#' @export
240		sampleSubjects.SimLongitudinalGSF <- function(object, subjects_df) {
241	10x	assert_that(
242	10x	is.factor(subjects_df$study),
243	10x	is.factor(subjects_df$arm),
244	10x	length(levels(subjects_df$study)) == length(object@mu_b),
245	10x	length(levels(subjects_df$arm)) == length(object@mu_s),
246	10x	length(levels(subjects_df$arm)) == length(object@mu_g),
247	10x	length(levels(subjects_df$arm)) == length(object@mu_phi)
248		)
249
250	10x	res <- subjects_df \|>
251	10x	dplyr::distinct(.data$subject, .data$arm, .data$study) \|>
252	10x	dplyr::mutate(
253	10x	study_idx = as.numeric(.data$study),
254	10x	arm_idx = as.numeric(.data$arm),
255	10x	psi_b = stats::rlnorm(
256	10x	dplyr::n(),
257	10x	object@mu_b[.data$study_idx],
258	10x	object@omega_b[.data$study_idx]
259		),
260	10x	psi_s = stats::rlnorm(
261	10x	dplyr::n(),
262	10x	object@mu_s[.data$arm_idx],
263	10x	object@omega_s[.data$arm_idx]
264		),
265	10x	psi_g = stats::rlnorm(
266	10x	dplyr::n(),
267	10x	object@mu_g[.data$arm_idx],
268	10x	object@omega_g[.data$arm_idx]
269		),
270	10x	psi_phi_logit = stats::rnorm(
271	10x	dplyr::n(),
272	10x	object@mu_phi[.data$arm_idx],
273	10x	object@omega_phi[.data$arm_idx]
274		),
275	10x	psi_phi = stats::plogis(.data$psi_phi_logit)
276		)
277	10x	res[, c("subject", "arm", "study", "psi_b", "psi_s", "psi_g", "psi_phi")]
278		}
279
280
281		## sim_lm_gsf ----
282
283		#' Generalized Stein-Fojo Functionals
284		#'
285		#' @typed time: numeric
286		#' time grid.
287		#' @typed b: number
288		#' baseline.
289		#' @typed s: number
290		#' shrinkage.
291		#' @typed g: number
292		#' growth.
293		#' @typed phi: number
294		#' shrinkage proportion.
295		#'
296		#' @returns The function results.
297		#'
298		#' @keywords internal
299		gsf_sld <- function(time, b, s, g, phi) {
300	25x	phi <- dplyr::if_else(time >= 0, phi, 0)
301	25x	b * (phi * exp(-s * time) + (1 - phi) * exp(g * time))
302		}
303
304
305		#' @rdname gsf_sld
306		gsf_ttg <- function(time, b, s, g, phi) {
307	22x	t1 <- (log(s * phi / (g * (1 - phi))) / (g + s))
308	22x	t1[t1 <= 0] <- 0
309	22x	return(t1)
310		}
311
312
313		#' @rdname gsf_sld
314		gsf_dsld <- function(time, b, s, g, phi) {
315	22x	phi <- dplyr::if_else(time >= 0, phi, 0)
316	22x	t1 <- (1 - phi) * g * exp(g * time)
317	22x	t2 <- phi * s * exp(-s * time)
318	22x	return(b * (t1 - t2))
319		}

1		#' Quantity Grid Specification
2		#'
3		#' @typed subjects: "`character` or `NULL`"
4		#' vector of subjects to extract quantities for.
5		#' If `NULL` will default to all subjects within the dataset.
6		#'
7		#' @typed times: "`numeric` or `NULL`"
8		#' vector of time points to extract quantities at.
9		#' If `NULL` will default to 201 evenly spaced timepoints between 0 and either the max
10		#' observation time (for [`LongitudinalQuantities`]) or max event time (for [`SurvivalQuantities`]).
11		#'
12		#' @typed groups: list
13		#' named list of subjects to extract quantities for. See Group Specification.
14		#'
15		#' @typed spec: list
16		#' named list of subjects to extract quantities for. The names of each
17		#' element should be the required subjects with the element itself being a numeric vector of timepoints
18		#' to generate the quantity at.
19		#'
20		#' @typed length.out: numeric
21		#' number of evenly spaced timepoints to generate quantities at.
22		#'
23		#' @typed newdata: data.frame
24		#' new data to generate quantities for. Must contain the same columns
25		#' and factor levels of the original data used in the [`DataSurvival`] object.
26		#'
27		#' @typed params: list
28		#' named list of parameters to fix the longitudinal model parameters at when
29		#' predicting survival quantities. See [`getPredictionNames()`] for the required parameters.
30		#'
31		#' @description
32		#' These functions are used to specify which subjects and timepoints should be generated
33		#' when calculating quantities via [`SurvivalQuantities`] and [`LongitudinalQuantities`].
34		#'
35		#' @details
36		#'
37		#' - `GridFixed()` is used to specify a fixed set of timepoints to generate quantities at for
38		#' all the specified subjects.
39		#'
40		#' - `GridGrouped()` is similar to `GridFixed()` but allows for groupwise averaging
41		#' (see Group Specification).
42		#'
43		#' - `GridObserved()` generates quantities at the observed longitudinal timepoints for each
44		#' subject.
45		#'
46		#' - `GridManual()` allows for individual timepoint specification for each subject.
47		#'
48		#' - `GridEven()` generates quantities for each subject at N evenly spaced timepoints
49		#' between each subjects first and last longitudinal observations.
50		#'
51		#' - `GridEvent()` generates one quantity for each subject at their event/censor time
52		#' as indicated by the `time` variable in the survival dataset.
53		#'
54		#' - `GridPopulation()` generates longitudinal model quantities based on the population parameters at the
55		#' specified time points. Generates 1 set of quantities for each distinct combination of `arm`
56		#' and `study` within the [`DataSubject`] object provided to the [`JointModel`].
57		#'
58		#' - `GridPrediction()` generates survival quantities based on any user-defined values at the
59		#' specified time points. This is useful for generating quantities for a new dataset
60		#' on specific longitudinal model parameters. See [`getPredictionNames()`] to determine which
61		#' longitudinal model parameters need to be defined for a given longitudinal model.
62		#'
63		#' @section Group Specification:
64		#' For `GridGrouped()`, `groups` must be a named list of character vectors. Each element of the list
65		#' must be a character vector of the subjects that will form the group where the element name
66		#' is the corresponding name of the group. For example if the goal was to create two groups
67		#' named `Group-1` and `Group-2` which are composed of the subjects `sub-1`, `sub-2` and
68		#' `sub-3`, `sub-4` respectively then this would be specified as:
69		#' ```
70		#' GridGrouped(
71		#' groups = list(
72		#' "Group-1" = c("sub-1", "sub-2"),
73		#' "Group-2" = c("sub-3", "sub-4")
74		#' )
75		#' )
76		#' ```
77		#' @seealso [`SurvivalQuantities`], [`LongitudinalQuantities`]
78		#' @name Grid-Functions
79		NULL
80
81
82		#' Grid Developer Notes
83		#'
84		#' @description
85		#' Developer details for implementing / extending `Grid` objects for defining
86		#' generated quantities for [`SurvivalQuantities`] and [`LongitudinalQuantities`].
87		#'
88		#' @slot subjects (`character` or `NULL`)\cr vector of subjects to extract quantities for.
89		#' If `NULL` will default to all subjects within the dataset.
90		#' @slot times (`numeric` or `NULL`)\cr vector of time points to extract quantities at.
91		#' If `NULL` will default to 201 evenly spaced timepoints between 0 and either the max
92		#' @slot groups (`list`)\cr named list of subjects to extract quantities for. See details.
93		#'
94		#' @details
95		#' All grid classes must inherit from the abstract `Grid` class.
96		#' All grid classes must provide `as.QuantityGenerator(object, data)` and
97		#' `as.QuantityCollapser(object, data)` methods where `data` is a [`DataJoint`] object.
98		#' These methods must return a `QuantityGenerator` and `QuantityCollapser` object respectively.
99		#' The `QuantityGenerator` object specifies unique subject/timepoint combinations that samples
100		#' should be generated at.
101		#' The `QuantityCollapser` object specifies how to combine these generated samples
102		#' to form the desired quantities.
103		#' As an example say we want to generate grouped samples for the groups `Group-1` and `Group-2`
104		#' which consist of the subjects `sub-1`, `sub-2` and `sub-3`, `sub-4` respectively at two time points
105		#' `10` and `20`. We can achieve this as follows:
106		#' ```
107		#' QuantityGenerator(
108		#' times = c(10, 10, 10, 10, 20, 20, 20, 20),
109		#' subjects = c("sub-1" "sub-2", "sub-3", "sub-4", "sub-1" "sub-2", "sub-3", "sub-4")
110		#' )
111		#' QuantityCollapser(
112		#' times = c(10, 20, 10 , 20),
113		#' groups = c("Group-1", "Group-1", "Group-2", "Group-2"),
114		#' indexes = list(c(1, 2), c(5, 6), c(3, 4), c(7, 8))
115		#' )
116		#' ```
117		#' For population based quantities use the `arms` and `studies` arguments of `QuantityGenerator`
118		#' instead of `subjects`.
119		#'
120		#' @inheritSection Grid-Functions Group Specification
121		#'
122		#' @keywords internal
123		#' @seealso `Quant-Dev`
124		#' @name Grid-Dev
125		NULL
126
127
128		#' Quantity Developer Notes
129		#'
130		#' @description
131		#' Developer details for `QuantityX` objects/methods. This page just outlines the arguments
132		#' and slots of these objects/methods. For the full implementation details please see [Grid-Dev]
133		#'
134		#' @slot times (`numeric`)\cr See Arguments for details.
135		#' @slot subjects (`character`)\cr See Arguments for details.
136		#' @slot groups (`character`)\cr See Arguments for details.
137		#' @slot indexes (`list`)\cr See Arguments for details.
138		#'
139		#' @typed times: numeric
140		#' vector of time points to extract quantities at.
141		#' @typed subjects: character
142		#' vector of subjects to extract quantities for.
143		#' @typed groups: character
144		#' vector of labels to apply to the generated quantities.
145		#' @typed indexes: list
146		#' list of indexes that specify which observations from a
147		#' `QuantityGenerator` should be combined to form the desired quantities.
148		#'
149		#' @typed object: Grid
150		#' object to convert to a `QuantityGenerator` or `QuantityCollapser`.
151		#' @typed data: DataJoint
152		#' Survival and Longitudinal Data.
153		#' @param ... Not currently used.
154		#'
155		#' @details
156		#' The `as.QuantityGenerator` must return a `QuantityGenerator` object.
157		#' The `as.QuantityCollapser` must return a `QuantityCollapser` object.
158		#' @keywords internal
159		#' @name Quant-Dev
160		NULL
161
162
163		#' @rdname Grid-Dev
164		.Grid <- setClass("Grid")
165
166
167		#' @rdname Quant-Dev
168		.QuantityGenerator <- setClass(
169		"QuantityGenerator"
170		)
171		#' `QuantityGenerator` -> `list`
172		#' @description
173		#' Converts a `QuantityGenerator` object to a list containing the required input data for a stan
174		#' model.
175		#' @typed object: QuantityGenerator
176		#' object to convert to a list.
177		#' @typed data: DataJoint
178		#' Survival and Longitudinal Data.
179		#' @param ... Not currently used.
180		#' @keywords internal
181		#' @exportS3Method NULL
182		as_stan_list.QuantityGenerator <- function(object, data, ...) {
183	!	stop("as_stan_list.QuantityGenerator not implemented")
184		}
185
186
187		#' @rdname Quant-Dev
188		.QuantityCollapser <- setClass(
189		"QuantityCollapser",
190		slots = c(
191		"times" = "numeric",
192		"groups" = "character",
193		"indexes" = "list"
194		)
195		)
196		#' @rdname Quant-Dev
197		QuantityCollapser <- function(times, groups, indexes) {
198	53x	.QuantityCollapser(
199	53x	times = times,
200	53x	groups = groups,
201	53x	indexes = indexes
202		)
203		}
204
205		setValidity(
206		"QuantityCollapser",
207		function(object) {
208		if (
209		length(object@times) != length(object@groups) \|\|
210		length(object@times) != length(object@indexes)
211		) {
212		return("Length of `times`, `groups`, and `indexes` must be equal")
213		}
214		}
215		)
216
217		#' @export
218		length.QuantityCollapser <- function(x) {
219	80x	length(x@indexes)
220		}
221
222
223		#' Expand and Validate Subjects
224		#'
225		#' @typed subjects: character
226		#' vector of subjects that should exist in `data`
227		#' @typed data: DataJoint
228		#' Survival and Longitudinal Data.
229		#'
230		#' @description
231		#' If `subjects` is `NULL` this will return a named list of all subjects in `data`.
232		#' Else it will return `subjects` as a named list ensuring that all subjects exist in `data`.
233		#'
234		#' @keywords internal
235		subjects_to_list <- function(subjects = NULL, data) {
236	74x	data_list <- as.list(data)
237	74x	subjects_exp <- if (is.null(subjects)) {
238	16x	subs <- as.list(names(data_list$subject_to_index))
239	16x	names(subs) <- names(data_list$subject_to_index)
240	16x	subs
241		} else {
242	58x	subs <- as.list(subjects)
243	58x	names(subs) <- subjects
244	58x	subs
245		}
246	74x	subjects_exp_vec <- unlist(subjects_exp, use.names = FALSE)
247	74x	assert_that(
248	74x	identical(subjects_exp_vec, unique(subjects_exp_vec)),
249	74x	msg = "All subject names must be unique"
250		)
251	74x	assert_that(
252	74x	all(subjects_exp_vec %in% names(data_list$subject_to_index)),
253	74x	msg = "Not all subjects exist within the data object"
254		)
255	73x	subjects_exp
256		}

1		#' @include generics.R
2		#' @include utilities.R
3		NULL
4
5		#' Re-used documentation for `DataSurvival`
6		#'
7		#' @typed object: DataSurvival
8		#' Survival Data.
9		#' @typed x: DataSurvival
10		#' Survival Data.
11		#' @param ... Not Used.
12		#'
13		#' @name DataSurvival-Shared
14		#' @keywords internal
15		NULL
16
17
18		# DataSurvival-class ----
19
20		#' Survival Data Object and Constructor Function
21		#'
22		#' The [`DataSurvival`] class handles the processing of the survival data
23		#' for fitting a [`JointModel`].
24		#'
25		#' @slot data (`data.frame`)\cr See Arguments for details.
26		#' @slot formula (`formula`)\cr See Arguments for details.
27		#'
28		#' @family DataObjects
29		#' @family DataSurvival
30		#' @exportClass DataSurvival
31		#' @export DataSurvival
32		.DataSurvival <- setClass(
33		Class = "DataSurvival",
34		representation = list(
35		data = "data.frame",
36		formula = "formula"
37		)
38		)
39
40		#' @typed data: data.frame
41		#' the observed time-to-event data.
42		#' @typed formula: formula
43		#' of the form `Surv(time, event) ~ cov1 + cov2 + ...`.
44		#' See [survival::Surv()] for more details, though note that this package only supports right censoring.
45		#' @rdname DataSurvival-class
46		DataSurvival <- function(data, formula) {
47	50x	.DataSurvival(
48	50x	data = remove_missing_rows(data, formula),
49	50x	formula = formula
50		)
51		}
52
53		setValidity(
54		"DataSurvival",
55		method = function(object) {
56		dat <- object@data
57		x <- extractVariableNames(object)
58		dnames <- names(dat)
59		if (nrow(object@data) == 0) {
60		return("`data` should not have 0 rows")
61		}
62		if (length(x$frm) != 3) {
63		return("`formula` should be a 2 sided formula")
64		}
65		LHS <- as.character(x$frm[[2]][[1]])
66		lhs_surv <- identical(LHS, "Surv")
67		lhs_colon_surv <- identical(LHS, c("::", "survival", "Surv"))
68		if (!(lhs_surv \|\| lhs_colon_surv)) {
69		return("The LHS of `formula` should be a call to survival::Surv()")
70		}
71		for (v in c(x$time, x$event)) {
72		if (!v %in% dnames) {
73		return(sprintf("Variable %s is not in `data`", x$subject))
74		}
75		}
76		return(TRUE)
77		}
78		)
79
80
81		#' @inheritParams DataSurvival-Shared
82		#' @inherit extractVariableNames description title
83		#'
84		#' @returns
85		#' A list with the following named elements:
86		#' - `frm` (`formula`)\cr a symbolic description of the survival model to be fitted
87		#' - `time` (`character`)\cr The name of the variable containing the event time
88		#' - `event` (`character`) \cr The name of the variable containing the event status
89		#' @export
90		#' @family DataSurvival
91		#' @family extractVariableNames
92		#' @keywords internal
93		extractVariableNames.DataSurvival <- function(object) {
94	397x	list(
95	397x	frm = object@formula,
96	397x	time = as.character(object@formula[[2]][[2]]),
97	397x	event = as.character(object@formula[[2]][[3]])
98		)
99		}
100
101
102		#' `DataSurvival` -> `data.frame`
103		#'
104		#' @inheritParams DataSurvival-Shared
105		#'
106		#' @description
107		#' Converts a [`DataSurvival`] object into a `data.frame`.
108		#' The subject variable is cast to factor.
109		#' @family DataSurvival
110		#' @export
111		as.data.frame.DataSurvival <- function(x, ...) {
112	392x	x <- x@data
113	392x	rownames(x) <- NULL
114	392x	x
115		}
116
117
118		#' @rdname as_stan_list.DataObject
119		#' @family DataSurvival
120		#' @export
121		as_stan_list.DataSurvival <- function(object, ...) {
122	331x	df <- as.data.frame(object)
123	331x	vars <- extractVariableNames(object)
124
125	331x	design_mat <- stats::model.matrix(vars$frm, data = df)
126	331x	remove_index <- grep("(Intercept)", colnames(design_mat), fixed = TRUE)
127	331x	design_mat <- design_mat[, -remove_index, drop = FALSE]
128	331x	rownames(design_mat) <- NULL
129
130		# Parameters for efficient integration of hazard function -> survival function
131	331x	gh_parameters <- statmod::gauss.quad(
132	331x	n = getOption("jmpost.gauss_quad_n"),
133	331x	kind = "legendre"
134		)
135
136	331x	model_data <- list(
137	331x	n_subject_event = sum(df[[vars$event]]),
138	331x	subject_event_index = which(df[[vars$event]] == 1),
139	331x	event_times = df[[vars$time]],
140	331x	p_os_cov_design = ncol(design_mat),
141	331x	os_cov_design = design_mat,
142	331x	n_nodes = length(gh_parameters$nodes),
143	331x	nodes = gh_parameters$nodes,
144	331x	weights = gh_parameters$weights
145		)
146	331x	return(model_data)
147		}
148
149		#' @rdname as_stan_list.DataObject
150		#' @export
151		as.list.DataSurvival <- function(x, ...) {
152	2x	as_stan_list(x, ...)
153		}
154
155		#' @rdname harmonise
156		#' @exportS3Method NULL
157		harmonise.DataSurvival <- function(object, subject_var, subject_ord, ...) {
158	23x	data <- as.data.frame(object)
159
160	23x	assert_string(subject_var, na.ok = FALSE)
161	23x	assert_character(subject_ord, any.missing = FALSE)
162	23x	assert_that(
163	23x	subject_var %in% names(data),
164	23x	msg = sprintf(
165	23x	"Subject variable `%s` not found in `survival`",
166	23x	subject_var
167		)
168		)
169	22x	assert_that(
170	22x	all(data[[subject_var]] %in% subject_ord),
171	22x	msg = "There are subjects in `survival` that are not present in `subjects`"
172		)
173	21x	assert_that(
174	21x	all(subject_ord %in% data[[subject_var]]),
175	21x	msg = "There are subjects in `subjects` that are not present in `survival`"
176		)
177
178	20x	data[[subject_var]] <- factor(
179	20x	as.character(data[[subject_var]]),
180	20x	levels = subject_ord
181		)
182
183	20x	data_ord <- data[order(data[[subject_var]]), ]
184
185	20x	DataSurvival(
186	20x	data = data_ord,
187	20x	formula = object@formula
188		)
189		}
190
191
192		#' `DataSurvival` -> Printable `Character`
193		#'
194		#' Converts [`DataSurvival`] object into a printable string.
195		#' @inheritParams DataSurvival-Shared
196		#' @family DataSurvival
197		#' @typed indent: numeric
198		#' how much white space to prefix the print string with.
199		#' @keywords internal
200		#' @export
201		as_print_string.DataSurvival <- function(object, indent = 1, ...) {
202	3x	template <- c(
203	3x	"Survival-Data Object:",
204	3x	" # of Rows = %d",
205	3x	" # of Columns = %d",
206	3x	" # of Events = %d",
207	3x	" Formula = %s"
208		)
209	3x	pad <- rep(" ", indent) \|> paste(collapse = "")
210	3x	template_padded <- paste(pad, template)
211	3x	vars <- extractVariableNames(object)
212	3x	sprintf(
213	3x	paste(template_padded, collapse = "\n"),
214	3x	nrow(object@data),
215	3x	ncol(object@data),
216	3x	sum(object@data[[vars$event]]),
217	3x	Reduce(paste, deparse(vars$frm))
218		)
219		}
220
221		#' @rdname show-object
222		#' @export
223		setMethod(
224		f = "show",
225		signature = "DataSurvival",
226		definition = function(object) {
227	1x	string <- as_print_string(object)
228	1x	cat("\n", string, "\n\n")
229		}
230		)
231
232		#' Build design matrix for prediction data
233		#'
234		#' @description
235		#' This function takes a `DataSurvival` object and a `data.frame` object and generates
236		#' a design matrix for the `data.frame` that has the identical structure to the
237		#' design matrix of the `DataSurvival` object.
238		#'
239		#' This is used for predicting new data using a model that was trained on a different
240		#' original data source
241		#'
242		#' @typed olddata: DataSurvival
243		#' The original data to be used as a template for the new data
244		#' @typed newdata: data.frame
245		#' The new data to be used to generate the design matrix
246		#' @importFrom stats .checkMFClasses terms delete.response model.frame model.matrix
247		#' @importFrom survival coxph
248		#' @keywords internal
249		mirror_design_matrix <- function(olddata, newdata) {
250	7x	frm <- as_formula(olddata)
251		# Dummy model to generate a bunch of meta information that we can use to
252		# re-construct the design matrix
253	7x	model <- coxph(data = as.data.frame(olddata), formula = frm)
254	7x	model_terms <- delete.response(terms(model))
255	7x	model_frame <- model.frame(
256	7x	model_terms,
257	7x	newdata,
258	7x	xlev = model$xlevels
259		)
260	4x	if (!is.null(data_classes <- attr(model_terms, "dataClasses"))) {
261	4x	.checkMFClasses(data_classes, model_frame)
262		}
263	3x	design_mat <- model.matrix(
264	3x	model_terms,
265	3x	model_frame,
266	3x	contrasts.arg = model$contrasts
267		)
268	3x	remove_index <- grep("(Intercept)", colnames(design_mat), fixed = TRUE)
269	3x	design_mat <- design_mat[, -remove_index, drop = FALSE]
270	3x	rownames(design_mat) <- NULL
271	3x	design_mat
272		}
273
274
275		#' @export
276		as_formula.DataSurvival <- function(x, ...) {
277	7x	vars <- extractVariableNames(x)
278	7x	vars$frm
279		}

1		#' @include DataJoint.R
2		#' @include Quantities.R
3		NULL
4
5
6		#' Re-used documentation for `LongitudinalQuantities`
7		#'
8		#' @typed x: LongitudinalQuantities
9		#' longitudinal quantities.
10		#' @typed object: LongitudinalQuantities
11		#' longitudinal quantities.
12		#' @param ... not used.
13		#'
14		#' @keywords internal
15		#' @name LongitudinalQuantities-Shared
16		NULL
17
18
19		#' `LongitudinalQuantities` Object & Constructor Function
20		#'
21		#' Constructor function to generate a `LongitudinalQuantities` object.
22		#'
23		#' @details
24		#' Note that unlike [`SurvivalQuantities`], [`LongitudinalQuantities`] does not support
25		#' group aggregation.
26		#'
27		#' @slot quantities (`Quantities`)\cr The sampled quantities. Should contain 1 element per
28		#' element of `group`
29		#'
30		#' @slot data (`DataJoint`)\cr Survival and Longitudinal Data.
31		#'
32		#' @family LongitudinalQuantities
33		#' @name LongitudinalQuantities-class
34		#' @export LongitudinalQuantities
35		.LongitudinalQuantities <- setClass(
36		"LongitudinalQuantities",
37		slots = c(
38		"quantities" = "Quantities",
39		"data" = "DataJoint"
40		)
41		)
42
43		#' @typed object: JointModelSamples
44		#' samples as drawn from a Joint Model.
45		#'
46		#' @typed grid: Grid
47		#' object that specifies which subjects and time points to calculate the
48		#' quantities for. See [Grid-Functions].
49		#' @rdname LongitudinalQuantities-class
50		LongitudinalQuantities <- function(
51		object,
52		grid
53		) {
54	14x	assert_class(object, "JointModelSamples")
55	14x	assert_class(grid, "Grid")
56	14x	assert_that(
57	14x	!is(grid, "GridPrediction"),
58	14x	msg = "`GridPrediction` objects are not supported for `LongitudinalQuantities`"
59		)
60
61	14x	time_grid <- seq(
62	14x	from = 0,
63	14x	to = max(as.list(object@data)[["tumour_time"]]),
64	14x	length = 201
65		)
66
67	14x	grid <- coalesceGridTime(grid, time_grid)
68
69	14x	gq <- generateQuantities(
70	14x	object,
71	14x	generator = as.QuantityGenerator(grid, object@data),
72	14x	type = "longitudinal"
73		)
74
75	14x	quantities_raw <- extract_quantities(gq, type = "lm_identity")
76
77	14x	collapser <- as.QuantityCollapser(grid, object@data)
78	14x	quantities <- collapse_quantities(quantities_raw, collapser)
79
80	14x	.LongitudinalQuantities(
81	14x	quantities = Quantities(
82	14x	quantities,
83	14x	groups = collapser@groups,
84	14x	times = collapser@times
85		),
86	14x	data = object@data
87		)
88		}
89
90
91		#' `as.data.frame`
92		#'
93		#' @typed x: LongitudinalQuantities
94		#' longitudinal quantities.
95		#' @param ... not used.
96		#' @family LongitudinalQuantities
97		#' @export
98		as.data.frame.LongitudinalQuantities <- function(x, ...) {
99	1x	as.data.frame(x@quantities)
100		}
101
102
103		#' summary
104		#'
105		#' @description
106		#' This method returns a `data.frame` of the longitudinal quantities.
107		#'
108		#' @typed conf.level: numeric
109		#' confidence level of the interval.
110		#' @inheritParams LongitudinalQuantities-Shared
111		#'
112		#' @family LongitudinalQuantities
113		#' @family summary
114		#' @export
115		summary.LongitudinalQuantities <- function(
116		object,
117		conf.level = 0.95,
118		...
119		) {
120	12x	summary(object@quantities, conf.level = conf.level)
121		}
122
123
124		#' Longitudinal Plot
125		#'
126		#' Internal plotting function to create longitudinal plots
127		#' This function predominately exists to extract core logic into its own function
128		#' to enable easier unit testing.
129		#'
130		#' @typed data: data.frame
131		#' summary statistics for longitudinal
132		#' value estimates. See details.
133		#' @typed data_obs: data.frame
134		#' real observed values to be
135		#' overlaid for reference. See details.
136		#' @typed add_ci: logical
137		#' Should confidence intervals be added? Default = `TRUE`.
138		#' @details
139		#'
140		#' ## `data`
141		#' Should contain the following columns:
142		#' - `time` (`numeric`) \cr time point for the summary statistic.
143		#' - `group` (`character`) \cr the group in which the observation belongs to.
144		#' - `median` (`numeric`) \cr the median value for the summary statistic.
145		#' - `upper` (`numeric`) \cr the upper 95% CI for the summary statistic.
146		#' - `lower` (`numeric`) \cr the lower 95% CI for the summary statistic.
147		#'
148		#' ## `data_obs`
149		#' Should contain the following columns:
150		#' - `time` (`numeric`) \cr the time at which the observed value occurred.
151		#' - `Yob` (`numeric`) \cr the real observed value.
152		#' - `group` (`character`) \cr which group the event belongs to, should correspond to
153		#' values in `data$group`.
154		#' @keywords internal
155		longitudinal_plot <- function(
156		data,
157		data_obs = NULL,
158		add_ci = FALSE
159		) {
160	4x	p <- ggplot() +
161	4x	geom_line(aes(x = .data$time, y = .data$median), data = data) +
162	4x	xlab(expression(t)) +
163	4x	ylab(expression(y)) +
164	4x	facet_wrap(~group) +
165	4x	theme_bw()
166
167	4x	if (add_ci) {
168	2x	p <- p +
169	2x	geom_ribbon(
170	2x	aes(x = .data$time, ymin = .data$lower, ymax = .data$upper),
171	2x	data = data,
172	2x	alpha = 0.3
173		)
174		}
175
176	4x	if (!is.null(data_obs)) {
177	4x	p <- p + geom_point(aes(x = .data$time, y = .data$Yob), data = data_obs)
178		}
179	4x	return(p)
180		}
181
182
183		#' Automatic Plotting for `LongitudinalQuantities`
184		#'
185		#' @typed conf.level: numeric
186		#' confidence level of the interval. If values of `FALSE`,
187		#' `NULL` or `0` are provided then confidence regions will not be added to the plot.
188		#' @inheritParams LongitudinalQuantities-Shared
189		#'
190		#' @family LongitudinalQuantities
191		#' @family autoplot
192		#' @export
193		autoplot.LongitudinalQuantities <- function(object, conf.level = 0.95, ...) {
194	2x	include_ci <- !is.null(conf.level) &&
195	2x	is.numeric(conf.level) &&
196	2x	conf.level > 0
197		# If CI aren't needed supply a default 0.95 to summary function as it needs
198		# a value to be specified to work.
199	2x	conf.level <- if (include_ci) conf.level else 0.95
200	2x	data_sum <- summary(object, conf.level = conf.level)
201	2x	data_obs <- extract_observed_values(object@data)
202	2x	assert_that(
203	2x	"group" %in% names(data_sum),
204	2x	"subject" %in% names(data_obs)
205		)
206	2x	data_obs$group <- data_obs$subject
207	2x	data_obs <- data_obs[data_obs$group %in% data_sum$group, ]
208	2x	longitudinal_plot(
209	2x	data = data_sum,
210	2x	data_obs = data_obs,
211	2x	add_ci = include_ci
212		)
213		}
214
215
216		#' @rdname show-object
217		#' @export
218		setMethod(
219		f = "show",
220		signature = "LongitudinalQuantities",
221		definition = function(object) {
222	2x	template <- c(
223	2x	"LongitudinalQuantities Object:",
224	2x	" # of samples = %d",
225	2x	" # of quantities = %d"
226		)
227	2x	string <- sprintf(
228	2x	paste(template, collapse = "\n"),
229	2x	nrow(object@quantities),
230	2x	ncol(object@quantities)
231		)
232	2x	cat("\n", string, "\n\n")
233		}
234		)

1		#' @include generics.R
2		#' @include StanModule.R
3		NULL
4
5		#' `Prior` Function Arguments
6		#'
7		#' The documentation lists all the conventional arguments for [`Prior`]
8		#' constructors.
9		#'
10		#' @typed centre: number
11		#' the central point of distribution to shrink sampled values towards
12		#' (for most distributions this is the mean or median if the mean is undefined)
13		#' @typed x: Prior
14		#' a prior Distribution
15		#' @typed object: Prior
16		#' a prior Distribution
17		#' @typed name: character
18		#' the name of the parameter the prior distribution is for
19		#' @param ... Not Used.
20		#'
21		#' @name Prior-Shared
22		#' @keywords internal
23		NULL
24
25		# Prior-class ----
26
27		#' Prior Object and Constructor Function
28		#'
29		#' Specifies the prior distribution in a Stan Model
30		#'
31		#' @slot parameters (`list`)\cr See arguments.
32		#' @slot repr_model (`string`)\cr See arguments.
33		#' @slot repr_data (`string`)\cr See arguments.
34		#' @slot centre (`numeric`)\cr See arguments.
35		#' @slot validation (`list`)\cr See arguments.
36		#' @slot display (`string`)\cr See arguments.
37		#' @slot sample (`function`)\cr See arguments.
38		#' @slot limits (`numeric`)\cr See arguments.
39		#'
40		#' @family Prior-internal
41		#' @export Prior
42		#' @exportClass Prior
43		.Prior <- setClass(
44		Class = "Prior",
45		slots = c(
46		"parameters" = "list",
47		"display" = "character",
48		"repr_model" = "character",
49		"repr_data" = "character",
50		"centre" = "numeric",
51		"validation" = "list",
52		"sample" = "function",
53		"limits" = "numeric"
54		)
55		)
56
57
58		#' @typed parameters: list
59		#' the prior distribution parameters.
60		#' @typed repr_model: string
61		#' the Stan code representation for the model block.
62		#' @typed repr_data: string
63		#' the Stan code representation for the data block.
64		#' @typed display: string
65		#' the string to display when object is printed.
66		#' @typed centre: numeric
67		#' the central point of distribution to shrink sampled values towards
68		#' @typed validation: list
69		#' the prior distribution parameter validation functions. Must have
70		#' the same names as the `paramaters` slot.
71		#' @typed sample: function
72		#' a function to sample from the prior distribution.
73		#' @typed limits: numeric
74		#' the lower and upper limits for a truncated distribution
75		#' @rdname Prior-class
76		Prior <- function(
77		parameters,
78		display,
79		repr_model,
80		repr_data,
81		centre,
82		validation,
83		sample,
84		limits = c(-Inf, Inf)
85		) {
86	1274x	.Prior(
87	1274x	parameters = parameters,
88	1274x	repr_model = repr_model,
89	1274x	repr_data = repr_data,
90	1274x	centre = centre,
91	1274x	display = display,
92	1274x	validation = validation,
93	1274x	sample = sample,
94	1274x	limits = limits
95		)
96		}
97
98
99		setValidity(
100		Class = "Prior",
101		method = function(object) {
102		for (param in names(object@parameters)) {
103		if (!param %in% names(object@validation)) {
104		return(sprintf(
105		"Parameter `%s` does not have a validation method",
106		param
107		))
108		}
109		if (length(object@parameters[[param]]) != 1) {
110		return(sprintf("Parameter `%s` must be a single value", param))
111		}
112		if (!object@validation[[param]](object@parameters[[param]])) {
113		return_message <- sprintf(
114		"Invalid value of `%d` for parameter `%s`",
115		object@parameters[[param]],
116		param
117		)
118		return(return_message)
119		}
120		}
121		if (length(object@limits) != 2) {
122		return("Limits must be a vector of length 2")
123		}
124		if (object@limits[1] >= object@limits[2]) {
125		return("Lower limit must be less than upper limit")
126		}
127		if (
128		length(object@repr_model) != 1 \|\| !is.character(object@repr_model)
129		) {
130		return("Model representation must be length 1 string")
131		}
132		return(TRUE)
133		}
134		)
135
136
137		#' @rdname set_limits
138		#' @export
139		set_limits.Prior <- function(object, lower = -Inf, upper = Inf) {
140	422x	object@limits <- c(lower, upper)
141	422x	validObject(object)
142	422x	return(object)
143		}
144
145
146		#' `Prior` -> `Character`
147		#'
148		#' Converts a [`Prior`] object to a character vector
149		#' @inheritParams Prior-Shared
150		#' @family Prior-internal
151		#' @export
152		as.character.Prior <- function(x, ...) {
153	177x	parameters_rounded <- lapply(x@parameters, round, 5)
154
155	177x	display_string <- do.call(
156	177x	glue::glue,
157	177x	append(x@display, parameters_rounded)
158		)
159	177x	display_limits <- render_stan_limits(x@limits)
160		if (
161	177x	display_limits != "" &&
162	177x	display_string != "" &&
163	177x	display_string != "<None>"
164		) {
165	59x	display_string <- paste0(display_string, display_limits)
166		}
167	177x	return(display_string)
168		}
169
170
171		#' Creates Stan Syntax for Truncated distributions
172		#' @description
173		#' This function creates the Stan syntax for truncated distributions
174		#' @typed limits: numeric
175		#' the lower and upper limits for a truncated distribution
176		#' @keywords internal
177		#' @typedreturn character
178		#' the Stan syntax for truncated distributions
179		render_stan_limits <- function(limits) {
180	1023x	l_bound <- if (limits[[1]] > -Inf) limits[[1]] else ""
181	1023x	u_bound <- if (limits[[2]] < Inf) limits[[2]] else ""
182	1023x	string <- ""
183	1023x	if (l_bound != "" \|\| u_bound != "") {
184	382x	string <- glue::glue(
185	382x	" T[{l_bound}, {u_bound}]",
186	382x	l_bound = l_bound,
187	382x	u_bound = u_bound
188		)
189		}
190	1023x	return(string)
191		}
192
193
194		#' @rdname show-object
195		#' @export
196		setMethod(
197		f = "show",
198		signature = "Prior",
199		definition = function(object) {
200	11x	x <- sprintf("\nPrior Object:\n %s\n\n", as.character(object))
201	11x	cat(x)
202	11x	return(object)
203		}
204		)
205
206
207		#' `Prior` -> `StanModule`
208		#'
209		#' Converts a [`Prior`] object to a [`StanModule`] object
210		#'
211		#' @inheritParams Prior-Shared
212		#'
213		#' @family Prior-internal
214		#' @family as.StanModule
215		#' @export
216		as.StanModule.Prior <- function(object, name, ...) {
217	951x	trunctation <- if (object@repr_model != "") {
218	846x	paste0(render_stan_limits(object@limits), ";")
219		} else {
220		""
221		}
222	951x	string <- paste(
223	951x	"data {{",
224	951x	paste0(" ", object@repr_data, collapse = "\n"),
225		"}}",
226	951x	"model {{",
227	951x	paste0(" ", object@repr_model, trunctation),
228		"}}",
229	951x	sep = "\n"
230		)
231	951x	StanModule(glue::glue(string, name = name))
232		}
233
234
235		#' `Prior` -> `list`
236		#'
237		#' Converts a Prior object to a list of parameter data values
238		#' for a Stan model.
239		#'
240		#' @inheritParams Prior-Shared
241		#'
242		#' @family as_stan_list
243		#' @family Prior-internal
244		#' @export
245		as_stan_list.Prior <- function(object, name, ...) {
246	435x	vals <- object@parameters
247	435x	vals_names <- names(vals)
248	435x	if (length(vals_names) >= 1) {
249	358x	names(vals) <- paste0("prior_", vals_names, "_", name)
250		}
251	435x	return(vals)
252		}
253
254
255		#' Prior Getter Functions
256		#' @description
257		#' Getter functions for the slots of a [`Prior`] object
258		#' @inheritParams Prior-Shared
259		#' @family Prior-internal
260		#' @name Prior-Getter-Methods
261		NULL
262
263
264		# initialValues-Prior ----
265
266		#' @describeIn Prior-Getter-Methods The prior's initial value
267		#' @export
268		initialValues.Prior <- function(object, ...) {
269	78596x	samples <- getOption("jmpost.prior_shrinkage") *
270	78596x	object@centre +
271	78596x	(1 - getOption("jmpost.prior_shrinkage")) * object@sample(100)
272
273	78596x	valid_samples <- samples[
274	78596x	samples >= min(object@limits) & samples <= max(object@limits)
275		]
276	78596x	assert_that(
277	78596x	length(valid_samples) >= 1,
278	78596x	msg = "Unable to generate an initial value that meets the required constraints"
279		)
280	78579x	if (length(valid_samples) == 1) {
281	26x	return(valid_samples)
282		}
283	78553x	return(sample(valid_samples, 1))
284		}
285
286
287		# Prior-constructors ----
288
289		#' Normal Prior Distribution
290		#'
291		#' @typed mu: number
292		#' mean.
293		#' @typed sigma: number
294		#' standard deviation.
295		#' @family Prior
296		#' @export
297		prior_normal <- function(mu, sigma) {
298	488x	Prior(
299	488x	parameters = list(mu = mu, sigma = sigma),
300	488x	display = "normal(mu = {mu}, sigma = {sigma})",
301	488x	repr_model = "{name} ~ normal(prior_mu_{name}, prior_sigma_{name})",
302	488x	repr_data = c(
303	488x	"real prior_mu_{name};",
304	488x	"real<lower=0> prior_sigma_{name};"
305		),
306	488x	centre = mu,
307	488x	sample = \(n) local_rnorm(n, mu, sigma),
308	488x	validation = list(
309	488x	mu = is.numeric,
310	488x	sigma = \(x) x > 0
311		)
312		)
313		}
314
315
316		#' Standard Normal Prior Distribution
317		#'
318		#'
319		#' @family Prior
320		#' @export
321		prior_std_normal <- function() {
322	208x	Prior(
323	208x	parameters = list(),
324	208x	display = "std_normal()",
325	208x	repr_model = "{name} ~ std_normal()",
326	208x	repr_data = "",
327	208x	centre = 0,
328	208x	sample = \(n) local_rnorm(n),
329	208x	validation = list()
330		)
331		}
332
333		#' Cauchy Prior Distribution
334		#'
335		#' @typed mu: number
336		#' mean.
337		#' @typed sigma: number
338		#' scale.
339		#' @family Prior
340		#'
341		#' @export
342		prior_cauchy <- function(mu, sigma) {
343	8x	Prior(
344	8x	parameters = list(mu = mu, sigma = sigma),
345	8x	display = "cauchy(mu = {mu}, sigma = {sigma})",
346	8x	repr_model = "{name} ~ cauchy(prior_mu_{name}, prior_sigma_{name})",
347	8x	repr_data = c(
348	8x	"real prior_mu_{name};",
349	8x	"real<lower=0> prior_sigma_{name};"
350		),
351	8x	centre = mu,
352	8x	sample = \(n) local_rcauchy(n, mu, sigma),
353	8x	validation = list(
354	8x	mu = is.numeric,
355	8x	sigma = \(x) x > 0
356		)
357		)
358		}
359
360
361		#' Gamma Prior Distribution
362		#'
363		#' @typed alpha: number
364		#' shape.
365		#' @typed beta: number
366		#' inverse scale.
367		#' @family Prior
368		#'
369		#' @export
370		prior_gamma <- function(alpha, beta) {
371	75x	Prior(
372	75x	parameters = list(alpha = alpha, beta = beta),
373	75x	repr_model = "{name} ~ gamma(prior_alpha_{name}, prior_beta_{name})",
374	75x	display = "gamma(alpha = {alpha}, beta = {beta})",
375	75x	repr_data = c(
376	75x	"real<lower=0> prior_alpha_{name};",
377	75x	"real<lower=0> prior_beta_{name};"
378		),
379	75x	centre = alpha / beta,
380	75x	sample = \(n) local_rgamma(n, shape = alpha, rate = beta),
381	75x	validation = list(
382	75x	alpha = \(x) x > 0,
383	75x	beta = \(x) x > 0
384		)
385		)
386		}
387
388		#' Log-Normal Prior Distribution
389		#'
390		#' @typed mu: number
391		#' mean of the logarithm.
392		#' @typed sigma: number
393		#' standard deviation of the logarithm.
394		#' @family Prior
395		#'
396		#' @export
397		prior_lognormal <- function(mu, sigma) {
398	395x	Prior(
399	395x	parameters = list(mu = mu, sigma = sigma),
400	395x	display = "lognormal(mu = {mu}, sigma = {sigma})",
401	395x	repr_model = "{name} ~ lognormal(prior_mu_{name}, prior_sigma_{name})",
402	395x	repr_data = c(
403	395x	"real prior_mu_{name};",
404	395x	"real<lower=0> prior_sigma_{name};"
405		),
406	395x	centre = exp(mu + (sigma^2) / 2),
407	395x	sample = \(n) local_rlnorm(n, mu, sigma),
408	395x	validation = list(
409	395x	mu = is.numeric,
410	395x	sigma = \(x) x > 0
411		)
412		)
413		}
414
415		#' Beta Prior Distribution
416		#'
417		#' @typed a: number
418		#' first parameter.
419		#' @typed b: number
420		#' second parameter
421		#' @family Prior
422		#'
423		#' @export
424		prior_beta <- function(a, b) {
425	8x	Prior(
426	8x	parameters = list(a = a, b = b),
427	8x	display = "beta(a = {a}, b = {b})",
428	8x	repr_model = "{name} ~ beta(prior_a_{name}, prior_b_{name})",
429	8x	repr_data = c(
430	8x	"real<lower=0> prior_a_{name};",
431	8x	"real<lower=0> prior_b_{name};"
432		),
433	8x	centre = a / (a + b),
434	8x	sample = \(n) local_rbeta(n, a, b),
435	8x	validation = list(
436	8x	a = \(x) x > 0,
437	8x	b = \(x) x > 0
438		)
439		)
440		}
441
442		#' Initial Values Specification
443		#'
444		#' @typed dist: Prior
445		#' a prior Distribution
446		#' @family Prior
447		#' @description
448		#' This function is used to specify only the initial values for a parameter.
449		#' This is primarily used for hierarchical parameters whose distributions
450		#' are fixed within the model and cannot be altered by the user.
451		#'
452		#' @export
453		prior_init_only <- function(dist) {
454	72x	Prior(
455	72x	parameters = list(),
456	72x	display = "<None>",
457	72x	repr_model = "",
458	72x	repr_data = "",
459	72x	sample = \(n) {
460	642x	dist@sample(n)
461		},
462	72x	centre = dist@centre,
463	72x	validation = list()
464		)
465		}
466
467
468		#' Uniform Prior Distribution
469		#'
470		#' @typed alpha: number
471		#' minimum value parameter.
472		#' @typed beta: number
473		#' maximum value parameter.
474		#' @family Prior
475		#'
476		#' @export
477		prior_uniform <- function(alpha, beta) {
478	6x	assert_that(
479	6x	alpha < beta,
480	6x	msg = "`alpha`` must be less than `beta`"
481		)
482	5x	Prior(
483	5x	parameters = list(alpha = alpha, beta = beta),
484	5x	display = "uniform(alpha = {alpha}, beta = {beta})",
485	5x	repr_model = "{name} ~ uniform(prior_alpha_{name}, prior_beta_{name})",
486	5x	repr_data = c(
487	5x	"real prior_alpha_{name};",
488	5x	"real prior_beta_{name};"
489		),
490	5x	centre = 0.5 * (alpha + beta),
491	5x	sample = \(n) local_runif(n, alpha, beta),
492	5x	validation = list(
493	5x	alpha = is.numeric,
494	5x	beta = is.numeric
495		)
496		)
497		}
498
499
500		#' Student-t Prior Distribution
501		#'
502		#' @typed nu: number
503		#' Degrees of freedom parameter.
504		#' @typed mu: number
505		#' Location parameter.
506		#' @typed sigma: number
507		#' Scale parameter.
508		#' @family Prior
509		#'
510		#' @export
511		prior_student_t <- function(nu, mu, sigma) {
512	4x	Prior(
513	4x	parameters = list(
514	4x	nu = nu,
515	4x	mu = mu,
516	4x	sigma = sigma
517		),
518	4x	display = "student_t(nu = {nu}, mu = {mu}, sigma = {sigma})",
519	4x	repr_model = "{name} ~ student_t(prior_nu_{name}, prior_mu_{name}, prior_sigma_{name})",
520	4x	repr_data = c(
521	4x	"real<lower=0> prior_nu_{name};",
522	4x	"real prior_mu_{name};",
523	4x	"real<lower=0> prior_sigma_{name};"
524		),
525	4x	centre = mu,
526	4x	sample = \(n) local_rt(n, nu, mu, sigma),
527	4x	validation = list(
528	4x	nu = \(x) x > 0,
529	4x	mu = is.numeric,
530	4x	sigma = \(x) x > 0
531		)
532		)
533		}
534
535
536		#' Logistic Prior Distribution
537		#'
538		#' @typed mu: number
539		#' Location parameter.
540		#' @typed sigma: number
541		#' Scale parameter.
542		#' @family Prior
543		#'
544		#' @export
545		prior_logistic <- function(mu, sigma) {
546	3x	Prior(
547	3x	parameters = list(
548	3x	mu = mu,
549	3x	sigma = sigma
550		),
551	3x	display = "logistic(mu = {mu}, sigma = {sigma})",
552	3x	repr_model = "{name} ~ logistic(prior_mu_{name}, prior_sigma_{name})",
553	3x	repr_data = c(
554	3x	"real prior_mu_{name};",
555	3x	"real<lower=0> prior_sigma_{name};"
556		),
557	3x	centre = mu,
558	3x	sample = \(n) local_rlogis(n, mu, sigma),
559	3x	validation = list(
560	3x	mu = is.numeric,
561	3x	sigma = \(x) x > 0
562		)
563		)
564		}
565
566
567		#' Log-Logistic Prior Distribution
568		#'
569		#' @typed alpha: number
570		#' Scale parameter.
571		#' @typed beta: number
572		#' Shape parameter.
573		#' @family Prior
574		#'
575		#' @export
576		prior_loglogistic <- function(alpha, beta) {
577	4x	Prior(
578	4x	parameters = list(
579	4x	alpha = alpha,
580	4x	beta = beta
581		),
582	4x	display = "loglogistic(alpha = {alpha}, beta = {beta})",
583	4x	repr_model = "{name} ~ loglogistic(prior_alpha_{name}, prior_beta_{name})",
584	4x	repr_data = c(
585	4x	"real<lower=0> prior_alpha_{name};",
586	4x	"real<lower=0> prior_beta_{name};"
587		),
588	4x	centre = alpha * pi / (beta * sin(pi / beta)),
589	4x	sample = \(n) {
590	!	local_rloglogis(n, alpha, beta)
591		},
592	4x	validation = list(
593	4x	alpha = \(x) x > 0,
594	4x	beta = \(x) x > 0
595		)
596		)
597		}
598
599
600		#' Inverse-Gamma Prior Distribution
601		#'
602		#' @typed alpha: number
603		#' Shape parameter.
604		#' @typed beta: number
605		#' Scale parameter.
606		#' @family Prior
607		#'
608		#' @export
609		prior_invgamma <- function(alpha, beta) {
610	4x	Prior(
611	4x	parameters = list(
612	4x	alpha = alpha,
613	4x	beta = beta
614		),
615	4x	display = "inv_gamma(alpha = {alpha}, beta = {beta})",
616	4x	repr_model = "{name} ~ inv_gamma(prior_alpha_{name}, prior_beta_{name})",
617	4x	repr_data = c(
618	4x	"real<lower=0> prior_alpha_{name};",
619	4x	"real<lower=0> prior_beta_{name};"
620		),
621	4x	centre = beta / (alpha - 1),
622	4x	sample = \(n) local_rinvgamma(n, alpha, beta),
623	4x	validation = list(
624	4x	alpha = \(x) x > 0,
625	4x	beta = \(x) x > 0
626		)
627		)
628		}
629
630
631		# nolint start
632		#
633		# Developer Notes
634		#
635		# The `median.Prior` function is a rough workaround to help generate initial values for
636		# hierarchical distributions. The original implementation involved sampling initial values
637		# for the random effects using the medians of the parent distribution e.g.
638		# ```
639		# random_effect ~ beta(a_prior@centre, b_prior@centre)
640		# ```
641		# A problem came up though when we implemented support for constrained distributions
642		# as there was no longer any guarantee that the median/centre of the distribution is
643		# a valid value e.g. `a_prior ~ prior_normal(-200, 400)`.
644		#
645		# To resolve this issue the `median.Prior` method was created which simply samples
646		# multiple observations from the constrained distribution and then takes the median
647		# of those constrained observations; this then ensures that the value being used
648		# for the parameters is a valid value
649		#
650		# nolint end
651		#' @importFrom stats median
652		#' @export
653		median.Prior <- function(x, na.rm, ...) {
654	138x	vals <- replicate(
655	138x	n = 500,
656	138x	initialValues(x),
657	138x	simplify = FALSE
658		) \|>
659	138x	unlist()
660	137x	median(vals)
661		}
662
663
664		#' Stub functions for sampling from distributions
665		#'
666		#' @description
667		#' These functions only exist so that they can be mocked during unit
668		#' tests in order to provide deterministic values. In most cases
669		#' these are just straight forward pass throughs for the underlying
670		#' distributions.
671		#'
672		#' @typed alpha: number
673		#' Parameter for underlying distribution.
674		#' @typed beta: number
675		#' Parameter for underlying distribution.
676		#' @typed mu: number
677		#' Parameter for underlying distribution.
678		#' @typed sigma: number
679		#' Parameter for underlying distribution.
680		#' @typed nu: number
681		#' Parameter for underlying distribution.
682		#' @param ... Pass any additional arguments to the underlying distribution.
683		#'
684		#' @importFrom stats rbeta rcauchy rgamma rlnorm rlogis rnorm rt runif
685		#'
686		#' @details
687		#'
688		#' ## Log-Logistic
689		#'
690		#' There is no log-logistic sampling function within base R so it was implemented
691		#' in terms of sampling from the CDF distribution. Using the Stan parameterisation
692		#' the CDF is defined as:
693		#' \deqn{
694		#' u = F(x) = \frac{1}{1 + (x/ \alpha)^{-\beta}}
695		#' }
696		#' The inverse of this function is:
697		#' \deqn{
698		#' x = ((u / (1 - u))^(1 / beta)) * alpha
699		#' }
700		#'
701		#' Thus we can sample u from a \eqn{Uni(0, 1)} distribution and then derive x from this.
702		#'
703		#' ## Inverse-Gamma
704		#'
705		#' The inverse Gamma distribution is defined as 1/Gamma thus we calculate this simply
706		#' by sampling sampling from the Gamma distribution and then taking the reciprocal.
707		#'
708		#' ## Student-t
709		#'
710		#' R's sampling functions only produce the standard Student-t distribution so in order
711		#' to match Stan's implementation we multiply by the scale parameter and add the location
712		#' parameter. See this \href{https://stats.stackexchange.com/a/623611}{Stack Overflow} post
713		#' for details
714		#'
715		#' @name Local_Sample
716		#' @keywords internal
717		NULL
718
719		#' @rdname Local_Sample
720	42317x	local_rnorm <- \(...) rnorm(...)
721
722		#' @rdname Local_Sample
723	700x	local_rcauchy <- \(...) rcauchy(...)
724
725		#' @rdname Local_Sample
726	604x	local_rgamma <- \(...) rgamma(...)
727
728		#' @rdname Local_Sample
729	34347x	local_rlnorm <- \(...) rlnorm(...)
730
731		#' @rdname Local_Sample
732	2x	local_rbeta <- \(...) rbeta(...)
733
734		#' @rdname Local_Sample
735	600x	local_runif <- \(...) runif(...)
736
737		#' @rdname Local_Sample
738		local_rt <- \(n, nu, mu, sigma) {
739	!	rt(n, nu) * sigma + mu
740		}
741
742		#' @rdname Local_Sample
743	!	local_rlogis <- \(...) rlogis(...)
744
745		#' @rdname Local_Sample
746		local_rloglogis <- \(n, alpha, beta) {
747	!	r <- runif(n)
748	!	((r / (1 - r))^(1 / beta)) * alpha
749		}
750
751		#' @rdname Local_Sample
752		local_rinvgamma <- \(n, alpha, beta) {
753	!	1 / rgamma(n, alpha, rate = beta)
754		}

1		#' @include generics.R
2		NULL
3
4		# STAN_BLOCKS ----
5
6		#' List of Stan Blocks
7		#'
8		#' @description
9		#' A list with 1 element per standard Stan program blocks.
10		#' This object is mostly used internally as a reference for
11		#' what blocks are expected to exist within a given Stan program.
12		#'
13		#' @export
14		STAN_BLOCKS <- list(
15		functions = "functions",
16		data = "data",
17		transformed_data = "transformed data",
18		parameters = "parameters",
19		transformed_parameters = "transformed parameters",
20		model = "model",
21		generated_quantities = "generated quantities"
22		)
23
24		# add_missing_stan_blocks ----
25
26		#' Add Missing Stan Blocks
27		#'
28		#' @typed x: list
29		#' list of Stan code blocks
30		#' @typed stan_blocks: list
31		#' reference list of stan blocks.
32		#'
33		#' @return Amended list `x` such that all blocks in the global variable
34		#' `STAN_BLOCKS` are contained.
35		#'
36		#' @keywords internal
37		add_missing_stan_blocks <- function(x, stan_blocks = STAN_BLOCKS) {
38	532x	for (block in names(stan_blocks)) {
39	3719x	if (is.null(x[[block]])) {
40	188x	x[[block]] <- ""
41		}
42		}
43	532x	return(x)
44		}
45
46		# StanModule-class ----
47
48		#' `StanModule` Object and Constructor Function
49		#'
50		#' @typed x: string
51		#' file path to a Stan program or a character vector
52		#' of Stan code to be parsed.
53		#' @param ... additional arguments passed to the constructor.
54		#'
55		#' @slot functions (`character`)\cr the `functions` block.
56		#' @slot data (`character`)\cr the `data` block.
57		#' @slot transformed_data (`character`)\cr the `transformed_data` block.
58		#' @slot parameters (`character`)\cr the `parameters` block.
59		#' @slot transformed_parameters (`character`)\cr the `transformed_parameters` block.
60		#' @slot model (`character`)\cr the `model` block.
61		#' @slot generated_quantities (`character`)\cr the `generated_quantities` block.
62		#'
63		#' @exportClass StanModule
64		#' @export StanModule
65		#' @family StanModule
66		.StanModule <- setClass(
67		Class = "StanModule",
68		slots = list(
69		functions = "character",
70		data = "character",
71		transformed_data = "character",
72		parameters = "character",
73		transformed_parameters = "character",
74		model = "character",
75		generated_quantities = "character"
76		)
77		)
78
79		# StanModule-constructors ----
80
81		#' @rdname StanModule-class
82		StanModule <- function(
83		x = "",
84		...
85		) {
86	3145x	assert_that(
87	3145x	is.character(x),
88	3145x	length(x) == 1,
89	3145x	msg = "`x` must be a length 1 character vector"
90		)
91	3145x	code <- read_stan(x)
92	3145x	code_fragments <- as_stan_fragments(code)
93
94		if (
95	3142x	paste0(unlist(code_fragments), collapse = "") == "" &&
96	3142x	paste0(x, collaspe = "") != ""
97		) {
98	1x	warning(
99	1x	"Non-empty input resulted in an empty StanModule object. Is the input correct?"
100		)
101		}
102
103	3142x	.StanModule(
104	3142x	functions = code_fragments$functions,
105	3142x	data = code_fragments$data,
106	3142x	transformed_data = code_fragments$transformed_data,
107	3142x	parameters = code_fragments$parameters,
108	3142x	transformed_parameters = code_fragments$transformed_parameters,
109	3142x	model = code_fragments$model,
110	3142x	generated_quantities = code_fragments$generated_quantities,
111		...
112		)
113		}
114
115		# as.character-StanModule ----
116
117		#' `StanModule` -> `character`
118		#' @typed x: StanModule
119		#' A stan program
120		#' @param ... Not Used.
121		#' @description
122		#' Converts a [`StanModule`] object into a valid Stan program file where each
123		#' line of the returned `character` vector represents a line of the program
124		#' @family StanModule
125		#' @export
126		as.character.StanModule <- function(x, ...) {
127	611x	as_stan_file(
128	611x	functions = x@functions,
129	611x	data = x@data,
130	611x	transformed_data = x@transformed_data,
131	611x	parameters = x@parameters,
132	611x	transformed_parameters = x@transformed_parameters,
133	611x	model = x@model,
134	611x	generated_quantities = x@generated_quantities
135		)
136		}
137
138
139		# merge-StanModule,StanModule ----
140
141		#' @typed stan_blocks: list
142		#' reference list of stan blocks.
143		#' @rdname merge
144		setMethod(
145		f = "merge",
146		signature = c("StanModule", "StanModule"),
147		definition = function(x, y, stan_blocks = STAN_BLOCKS, ...) {
148	1230x	stan_fragments <- lapply(
149	1230x	names(stan_blocks),
150	1230x	\(par) {
151	8610x	if (all(slot(y, par) == "")) {
152	5915x	return(slot(x, par))
153		}
154	2695x	if (all(slot(x, par) == "")) {
155	691x	return(slot(y, par))
156		}
157	2004x	return(c(slot(x, par), slot(y, par)))
158		}
159		)
160	1230x	names(stan_fragments) <- names(stan_blocks)
161	1230x	stan_code <- do.call(as_stan_file, stan_fragments)
162	1230x	StanModule(
163	1230x	x = stan_code
164		)
165		}
166		)
167
168		# compileStanModel-StanModule,character ----
169
170		#' @rdname compileStanModel
171		#' @exportS3Method NULL
172		compileStanModel.StanModule <- function(object) {
173	54x	exe_dir <- getOption("jmpost.cache_dir")
174	54x	if (!dir.exists(exe_dir)) {
175	3x	dir.create(exe_dir, recursive = TRUE)
176		}
177	54x	stan_code <- as.character(object)
178	54x	hash_name <- digest::digest(stan_code, "md5")
179	54x	exe_name <- paste0(
180	54x	"model_",
181	54x	hash_name,
182	54x	if (is_windows()) ".exe" else ""
183		)
184	54x	exe_file <- file.path(exe_dir, exe_name)
185	54x	source_file <- cmdstanr::write_stan_file(
186	54x	code = stan_code,
187	54x	dir = exe_dir,
188	54x	basename = sprintf("model_%s.stan", hash_name)
189		)
190
191		# Suppress "model executable is up to date" message as
192		# users are not in control of the cache so this message is meaningless
193	54x	withCallingHandlers(
194		{
195	54x	x <- cmdstanr::cmdstan_model(
196	54x	stan_file = source_file,
197	54x	exe_file = exe_file,
198	54x	quiet = TRUE
199		)
200		},
201	54x	message = function(m) {
202	!	if (m$message == "Model executable is up to date!\n") {
203	!	invokeRestart("muffleMessage")
204		}
205		}
206		)
207	54x	invisible(x)
208		}
209
210
211		# as.list-StanModule ----
212
213		#' `StanModule` -> `list`
214		#' @description
215		#' Returns a named list where each element of the list corresponds
216		#' to a Stan modelling block e.g. `data`, `model`, etc.
217		#' @typed x: StanModule
218		#' A Stan Module
219		#' @typed stan_blocks: list
220		#' reference list of stan blocks.
221		#' @param ... Not Used.
222		#' @family StanModule
223		#' @export
224		as.list.StanModule <- function(x, stan_blocks = STAN_BLOCKS, ...) {
225	504x	string <- as.character(x)
226	504x	li <- as_stan_fragments(string)
227	504x	for (block in names(stan_blocks)) {
228	3528x	li[[block]] <- paste(li[[block]], collapse = "\n")
229		}
230	504x	return(li)
231		}
232
233		# is_file ----
234
235		#' Is String a Valid File?
236		#'
237		#' A utility function to check if a string is a valid file or not.
238		#' Used to help address short comings of [file.exists()] that will return `TRUE`
239		#' for a directory as well as a file.
240		#'
241		#' @typed filename: string
242		#' file name.
243		#'
244		#' @keywords internal
245		is_file <- function(filename = NULL) {
246	10536x	if (is.null(filename)) {
247	!	return(FALSE)
248		}
249	10536x	assert_that(
250	10536x	is.character(filename),
251	10536x	length(filename) == 1,
252	10536x	msg = "`filename` must be a length 1 character"
253		)
254	10536x	if (nchar(filename) > 1000) {
255	2184x	return(FALSE)
256		}
257	8352x	if (is.na(filename)) {
258	!	return(FALSE)
259		}
260	8352x	return(file.exists(filename) & !dir.exists(filename))
261		}
262
263		# read_stan ----
264
265		#' Stan Code as Character
266		#'
267		#' @param string Character, either the absolute path of a stan file, or the name of the stan
268		#' file in the package directory or the stan code as a string.
269		read_stan <- function(string) {
270	3520x	local_inst_file <- file.path("inst", "stan", string)
271	3520x	system_file <- system.file(file.path("stan", string), package = "jmpost")
272	3520x	local_file <- string
273	3520x	files <- c(local_file, local_inst_file, system_file)
274	3520x	for (fi in files) {
275	10536x	if (is_file(fi)) {
276	844x	string <- readLines(fi)
277	844x	break
278		}
279		}
280	3520x	string <- paste0(string, collapse = "\n")
281	3520x	return(string)
282		}
283
284		# as_stan_file ----
285
286		#' Merging Code Blocks into Stan Code Character Vector
287		#'
288		#' @typed functions: character
289		#' code block.
290		#' @typed data: character
291		#' code block.
292		#' @typed transformed_data: character
293		#' code block.
294		#' @typed parameters: character
295		#' code block.
296		#' @typed transformed_parameters: character
297		#' code block.
298		#' @typed model: character
299		#' code block.
300		#' @typed generated_quantities: character
301		#' code block.
302		#' @typed stan_blocks: list
303		#' reference list of stan blocks.
304		#'
305		#' @return Character vector of the complete Stan code.
306		#'
307		#' @keywords internal
308		as_stan_file <- function(
309		functions = "",
310		data = "",
311		transformed_data = "",
312		parameters = "",
313		transformed_parameters = "",
314		model = "",
315		generated_quantities = "",
316		stan_blocks = STAN_BLOCKS
317		) {
318	1841x	block_strings <- lapply(
319	1841x	names(stan_blocks),
320	1841x	function(id) {
321	12887x	char <- get(id)
322	12887x	if (any(nchar(char) >= 1)) {
323	5939x	return(sprintf(
324	5939x	"%s {\n%s\n}\n\n",
325	5939x	stan_blocks[[id]],
326	5939x	paste(char, collapse = "\n")
327		))
328		} else {
329	6948x	return("")
330		}
331		}
332		)
333	1841x	return(paste0(block_strings, collapse = ""))
334		}
335
336		# as_stan_fragments ----
337
338		#' Conversion of Character Vector into Stan Code Block List
339		#'
340		#' @typed x: character
341		#' the single Stan code vector.
342		#' @typed stan_blocks: list
343		#' reference list of stan blocks.
344		#'
345		#' @return A list with the Stan code blocks.
346		#'
347		#' @details
348		#' Function only works if code is in format
349		#' ```
350		#' data {
351		#' <code>
352		#' }
353		#' model {
354		#' <code>
355		#' }
356		#' ```
357		#' That is to say we do not support code in inline format i.e.
358		#' ```
359		#' data { <code> }
360		#' model { <code> }
361		#' ```
362		#'
363		#' @keywords internal
364		as_stan_fragments <- function(x, stan_blocks = STAN_BLOCKS) {
365	3649x	code <- unlist(stringr::str_split(x, "\n"))
366
367	3649x	errmsg <- paste(
368	3649x	"There were problems parsing the `%s` block.",
369	3649x	"Please consult the `Formatting Stan Files` section of the",
370	3649x	"`Extending jmpost` vignette"
371		)
372
373		# Check to see if any block openings exist that have code on the same line
374		# e.g. `data { int i;}`. This is unsupported so we throw an error
375	3649x	for (block in stan_blocks) {
376	25538x	regex <- sprintf("^\\s%s\\s\\{\\s*[^\\s-]+", block)
377	25538x	if (any(grepl(regex, code, perl = TRUE))) {
378	2x	stop(sprintf(errmsg, block))
379		}
380		}
381
382		# We first look to identify the opening of a block e.g. `data {`
383		# We then regard all lines that follow as belonging to that block
384		# until we see another block being opened e.g. `model{`
385	3647x	results <- list()
386	3647x	target <- NULL
387	3647x	for (line in code) {
388	267269x	for (block in names(stan_blocks)) {
389	1838923x	regex <- sprintf("^\\s%s\\s\\{\\s*$", stan_blocks[[block]])
390	1838923x	if (stringr::str_detect(line, regex)) {
391	10035x	target <- block
392	10035x	line <- NULL
393	10035x	break
394		}
395		}
396	267269x	if (!is.null(target)) {
397		# This is memory inefficient but given the relatively small size of
398		# stan files its regarded as a acceptable simplification to ease the
399		# code burden
400	265953x	results[[target]] <- c(results[[target]], line)
401		}
402		}
403
404		# Loop over each block to remove trailing "}".
405	3647x	for (block in names(results)) {
406	10034x	block_length <- length(results[[block]])
407		# The following processing is only required if the block actually has content
408	10034x	if (block_length == 1 && results[[block]] == "") {
409	!	next
410		}
411	10034x	has_removed_char <- FALSE
412		# Walk backwards to find the closing `}` that corresponds to the `<block> {`
413	10034x	for (index in rev(seq_len(block_length))) {
414	21779x	line <- results[[block]][[index]]
415		# This code will exit the for loop as soon as it hits the closing `}`
416		# thus if we ever see a line that ends in text/numbers it means
417		# somethings gone wrong
418	21779x	if (stringr::str_detect(line, "[\\w\\d]+\\s*$")) {
419	1x	stop(sprintf(errmsg, block))
420		}
421	21778x	if (stringr::str_detect(line, "\\}\\s*$")) {
422	10033x	new_line <- stringr::str_replace(line, "\\s\\}\\s$", "")
423		# If the line is now blank after removing the closing `}` then drop the line
424	10033x	keep_offset <- if (nchar(new_line) == 0) -1 else 0
425		# Only keep lines from the start of the block to the closing `}`
426		# this is to ensure we drop blank lines that were between the end
427		# of the block and the start of the next
428	10033x	keep_range <- seq_len(index + keep_offset)
429	10033x	results[[block]][[index]] <- new_line
430	10033x	results[[block]] <- results[[block]][keep_range]
431	10033x	has_removed_char <- TRUE
432	10033x	break
433		}
434		}
435		# If we haven't actually removed a closing `}` then something has gone wrong...
436	10033x	if (!has_removed_char) {
437	!	stop(sprintf(errmsg, block))
438		}
439		}
440
441		# Add any missing blocks back in
442	3646x	for (block in names(stan_blocks)) {
443	25522x	if (is.null(results[[block]])) {
444	15489x	results[[block]] <- ""
445		}
446		}
447	3646x	results
448		}
449
450		#' `StanModule` -> Printable `Character`
451		#'
452		#' Converts [`StanModule`] object into a printable string.
453		#' @typed object: StanModule
454		#' A stan program
455		#' @family StanModule
456		#' @typed indent: numeric
457		#' how much white space to prefix the print string with.
458		#' @keywords internal
459		#' @export
460		as_print_string.StanModule <- function(object, indent = 1, ...) {
461	4x	slots <- names(getSlots("StanModule"))
462	4x	components <- Filter(
463	4x	\(block) paste(slot(object, block), collapse = "") != "",
464	4x	slots
465		)
466	4x	template <- c(
467	4x	"StanModule Object with components:",
468	4x	paste(" ", components)
469		)
470	4x	pad <- rep(" ", indent) \|> paste(collapse = "")
471	4x	template_padded <- paste(pad, template)
472	4x	sprintf(
473	4x	paste(template_padded, collapse = "\n")
474		)
475		}
476
477		#' @rdname show-object
478		#' @export
479		setMethod(
480		f = "show",
481		signature = "StanModule",
482		definition = function(object) {
483	4x	string <- as_print_string(object)
484	4x	cat("\n", string, "\n\n")
485		}
486		)

1		#' @include LongitudinalModel.R
2		#' @include StanModule.R
3		#' @include generics.R
4		#' @include ParameterList.R
5		#' @include Parameter.R
6		#' @include Link.R
7		NULL
8
9
10		#' `LongitudinalSteinFojo`
11		#'
12		#' This class extends the general [`LongitudinalModel`] class for using the
13		#' Stein-Fojo model for the longitudinal outcome.
14		#'
15		#' @section Available Links:
16		#' - [`linkDSLD()`]
17		#' - [`linkTTG()`]
18		#' - [`linkIdentity()`]
19		#' - [`linkGrowth()`]
20		#' @exportClass LongitudinalSteinFojo
21		.LongitudinalSteinFojo <- setClass(
22		Class = "LongitudinalSteinFojo",
23		contains = "LongitudinalModel"
24		)
25
26
27		#' @rdname LongitudinalSteinFojo-class
28		#'
29		#' @typed mu_bsld: Prior
30		#' for the mean baseline value `mu_bsld`.
31		#' @typed mu_ks: Prior
32		#' for the mean shrinkage rate `mu_ks`.
33		#' @typed mu_kg: Prior
34		#' for the mean growth rate `mu_kg`.
35		#'
36		#' @typed omega_bsld: Prior
37		#' for the baseline value standard deviation `omega_bsld`.
38		#' @typed omega_ks: Prior
39		#' for the shrinkage rate standard deviation `omega_ks`.
40		#' @typed omega_kg: Prior
41		#' for the growth rate standard deviation `omega_kg`.
42		#'
43		#' @typed sigma: Prior
44		#' for the variance of the longitudinal values `sigma`.
45		#'
46		#' @typed scaled_variance: logical
47		#' whether the variance should be scaled by the expected value
48		#' (see the "Statistical Specifications" vignette for more details)
49		#' @typed centred: logical
50		#' whether to use the centred parameterization.
51		#'
52		#' @export
53		LongitudinalSteinFojo <- function(
54		mu_bsld = prior_normal(log(60), 1),
55		mu_ks = prior_normal(log(0.5), 1),
56		mu_kg = prior_normal(log(0.3), 1),
57
58		omega_bsld = prior_lognormal(log(0.2), 1),
59		omega_ks = prior_lognormal(log(0.2), 1),
60		omega_kg = prior_lognormal(log(0.2), 1),
61
62		sigma = prior_lognormal(log(0.1), 1),
63
64		scaled_variance = TRUE,
65		centred = FALSE
66		) {
67	17x	sf_model <- StanModule(decorated_render(
68	17x	.x = read_stan("lm-stein-fojo/model.stan"),
69	17x	centred = centred,
70	17x	scaled_variance = scaled_variance
71		))
72
73		# Apply constriants
74	17x	omega_bsld <- set_limits(omega_bsld, lower = 0)
75	17x	omega_ks <- set_limits(omega_ks, lower = 0)
76	17x	omega_kg <- set_limits(omega_kg, lower = 0)
77	17x	sigma <- set_limits(sigma, lower = 0)
78
79	17x	parameters <- list(
80	17x	Parameter(name = "lm_sf_mu_bsld", prior = mu_bsld, size = "n_studies"),
81	17x	Parameter(name = "lm_sf_mu_ks", prior = mu_ks, size = "n_arms"),
82	17x	Parameter(name = "lm_sf_mu_kg", prior = mu_kg, size = "n_arms"),
83
84	17x	Parameter(
85	17x	name = "lm_sf_omega_bsld",
86	17x	prior = omega_bsld,
87	17x	size = "n_studies"
88		),
89	17x	Parameter(name = "lm_sf_omega_ks", prior = omega_ks, size = "n_arms"),
90	17x	Parameter(name = "lm_sf_omega_kg", prior = omega_kg, size = "n_arms"),
91
92	17x	Parameter(name = "lm_sf_sigma", prior = sigma, size = 1)
93		)
94
95	17x	assert_flag(centred)
96	17x	parameters_extra <- if (centred) {
97	3x	list(
98	3x	Parameter(
99	3x	name = "lm_sf_psi_bsld",
100	3x	prior = prior_init_only(prior_lognormal(
101	3x	median(mu_bsld),
102	3x	median(omega_bsld)
103		)),
104	3x	size = "n_subjects"
105		),
106	3x	Parameter(
107	3x	name = "lm_sf_psi_ks",
108	3x	prior = prior_init_only(prior_lognormal(
109	3x	median(mu_ks),
110	3x	median(omega_ks)
111		)),
112	3x	size = "n_subjects"
113		),
114	3x	Parameter(
115	3x	name = "lm_sf_psi_kg",
116	3x	prior = prior_init_only(prior_lognormal(
117	3x	median(mu_kg),
118	3x	median(omega_kg)
119		)),
120	3x	size = "n_subjects"
121		)
122		)
123		} else {
124	14x	list(
125	14x	Parameter(
126	14x	name = "lm_sf_eta_tilde_bsld",
127	14x	prior = prior_std_normal(),
128	14x	size = "n_subjects"
129		),
130	14x	Parameter(
131	14x	name = "lm_sf_eta_tilde_ks",
132	14x	prior = prior_std_normal(),
133	14x	size = "n_subjects"
134		),
135	14x	Parameter(
136	14x	name = "lm_sf_eta_tilde_kg",
137	14x	prior = prior_std_normal(),
138	14x	size = "n_subjects"
139		)
140		)
141		}
142	17x	parameters <- append(parameters, parameters_extra)
143
144	17x	x <- LongitudinalModel(
145	17x	name = "Stein-Fojo",
146	17x	stan = merge(
147	17x	sf_model,
148	17x	StanModule("lm-stein-fojo/functions.stan")
149		),
150	17x	parameters = do.call(ParameterList, parameters)
151		)
152	17x	.LongitudinalSteinFojo(x)
153		}
154
155
156		#' @export
157		enableGQ.LongitudinalSteinFojo <- function(object, ...) {
158	2x	StanModule("lm-stein-fojo/quantities.stan")
159		}
160
161		#' @export
162		enableLink.LongitudinalSteinFojo <- function(object, ...) {
163	3x	object@stan <- merge(
164	3x	object@stan,
165	3x	StanModule("lm-stein-fojo/link.stan")
166		)
167	3x	object
168		}
169
170		#' @export
171		linkDSLD.LongitudinalSteinFojo <- function(
172		prior = prior_normal(0, 2),
173		model,
174		...
175		) {
176	2x	LinkComponent(
177	2x	key = "link_dsld",
178	2x	stan = StanModule("lm-stein-fojo/link_dsld.stan"),
179	2x	prior = prior
180		)
181		}
182
183		#' @export
184		linkTTG.LongitudinalSteinFojo <- function(
185		prior = prior_normal(0, 2),
186		model,
187		...
188		) {
189	1x	LinkComponent(
190	1x	key = "link_ttg",
191	1x	stan = StanModule("lm-stein-fojo/link_ttg.stan"),
192	1x	prior = prior
193		)
194		}
195
196		#' @export
197		linkIdentity.LongitudinalSteinFojo <- function(
198		prior = prior_normal(0, 2),
199		model,
200		...
201		) {
202	!	LinkComponent(
203	!	key = "link_identity",
204	!	stan = StanModule("lm-stein-fojo/link_identity.stan"),
205	!	prior = prior
206		)
207		}
208
209		#' @export
210		linkGrowth.LongitudinalSteinFojo <- function(
211		prior = prior_normal(0, 2),
212		model,
213		...
214		) {
215	2x	LinkComponent(
216	2x	key = "link_growth",
217	2x	stan = StanModule("lm-stein-fojo/link_growth.stan"),
218	2x	prior = prior
219		)
220		}
221
222		#' @export
223		linkShrinkage.LongitudinalSteinFojo <- function(
224		prior = prior_normal(0, 2),
225		model,
226		...
227		) {
228	1x	LinkComponent(
229	1x	key = "link_shrinkage",
230	1x	stan = StanModule("lm-stein-fojo/link_shrinkage.stan"),
231	1x	prior = prior
232		)
233		}
234
235		#' @rdname getPredictionNames
236		#' @export
237		getPredictionNames.LongitudinalSteinFojo <- function(object, ...) {
238	1x	c("b", "s", "g")
239		}
240
241
242		#' @rdname getRandomEffectsNames
243		#' @export
244		getRandomEffectsNames.LongitudinalSteinFojo <- function(object, ...) {
245	!	c(
246	!	"b" = "lm_sf_psi_bsld",
247	!	"s" = "lm_sf_psi_ks",
248	!	"g" = "lm_sf_psi_kg"
249		)
250		}

1		#' Re-used documentation for `Quantities`
2		#'
3		#' @typed x: Quantities
4		#' generated quantities.
5		#' @typed object: Quantities
6		#' generated quantities.
7		#' @typed type: character
8		#' sets the `type` variable.
9		#' @typed conf.level: numeric
10		#' confidence level of the interval.
11		#' @param ... not used.
12		#'
13		#' @keywords internal
14		#' @name Quantities-Shared
15		NULL
16
17
18		#' Generated Quantities Container
19		#'
20		#' A simple wrapper around a `matrix` to store required metadata
21		#'
22		#' @typed quantities: matrix
23		#' of generated quantities.
24		#' @typed times: numeric
25		#' labels specifying which time point the quantity was generated at.
26		#' @typed groups: character
27		#' labels for which group the quantity belongs to.
28		#'
29		#' @slot quantities (`matrix`)\cr See Arguments for details.
30		#' @slot times (`numeric`)\cr See Arguments for details.
31		#' @slot groups (`character`)\cr See Arguments for details.
32		#'
33		#' @details
34		#' Each row of the matrix represents a sample and each column represents a distinct quantity.
35		#' As such the number of columns in the matrix should equal the length of `times` and `groups`
36		#' which provide metadata for who the quantity belongs to and at what time point it was generated at.
37		#'
38		#' @keywords internal
39		#' @name Quantities-class
40		#' @family Quantities
41		.Quantities <- setClass(
42		"Quantities",
43		slots = list(
44		"quantities" = "matrix",
45		"times" = "numeric",
46		"groups" = "character"
47		)
48		)
49		#' @rdname Quantities-class
50		Quantities <- function(quantities, times, groups) {
51	40x	.Quantities(
52	40x	quantities = quantities,
53	40x	times = times,
54	40x	groups = groups
55		)
56		}
57
58		setValidity(
59		Class = "Quantities",
60		method = function(object) {
61		if (length(object@times) != length(object@groups)) {
62		return("Length of `times` must be equal to the length of `groups`")
63		}
64		if (length(object@times) != ncol(object@quantities)) {
65		return(
66		"Length of `times` must be equal to the number of columns in `quantities`"
67		)
68		}
69		return(TRUE)
70		}
71		)
72
73
74		#' @export
75		dim.Quantities <- function(x) {
76	13x	dim(x@quantities)
77		}
78
79
80		#' `Quantities` -> `data.frame`
81		#'
82		#' @inheritParams Quantities-Shared
83		#'
84		#' @keywords internal
85		#' @family Quantities
86		#' @export
87		as.data.frame.Quantities <- function(x, ...) {
88	2x	data.frame(
89	2x	group = rep(x@groups, each = nrow(x@quantities)),
90	2x	time = rep(x@times, each = nrow(x@quantities)),
91	2x	values = as.vector(x@quantities)
92		)
93		}
94
95
96		#' summary
97		#'
98		#' @description
99		#' This method returns a summary statistic `data.frame` of the quantities. Note that this
100		#' is just an internal utility method in order to share common code between
101		#' [LongitudinalQuantities] and [SurvivalQuantities]
102		#'
103		#' @inheritParams Quantities-Shared
104		#'
105		#' @returns
106		#' A `data.frame` with the following variables:
107		#' - `median` (`numeric`) \cr the median value of the quantity.
108		#' - `lower` (`numeric`) \cr the lower CI value of the quantity.
109		#' - `upper` (`numeric`) \cr the upper CI value of the quantity.
110		#' - `time` (`numeric`) \cr the time point which the quantity is for.
111		#' - `group` (`character`) \cr which group the quantity belongs to.
112		#' - `type` (`character`) \cr what type of quantity is it.
113		#'
114		#' @keywords internal
115		#' @family Quantities
116		#' @export
117		summary.Quantities <- function(object, conf.level = 0.95, ...) {
118	34x	quantities_summarised <- samples_median_ci(
119	34x	object@quantities,
120	34x	level = conf.level
121		)
122
123	34x	quantities_summarised$group <- object@groups
124	34x	quantities_summarised$time <- object@times
125	34x	quantities_summarised[, c("group", "time", "median", "lower", "upper")]
126		}
127
128
129		#' Create Grouped Quantities
130		#'
131		#' This function takes a matrix of quantity samples and aggregates them by calculating the
132		#' pointwise average.
133		#'
134		#' @typed quantities_raw: matrix
135		#' of samples with 1 row per sample and 1 column per
136		#' distinct quantity.
137		#'
138		#' @typed collapser: QuantityCollapser
139		#' specifies which columns to combine together.
140		#'
141		#' @details
142		#' This function essentially implements the group wise average by collapsing multiple columns
143		#' together based on the specification provided by the `QuantityCollapser` object.
144		#' The [Grid-Dev] page provides an example of what this function implements
145		#'
146		#' @keywords internal
147		collapse_quantities <- function(quantities_raw, collapser) {
148	40x	assert_class(quantities_raw, "matrix")
149	40x	assert_class(collapser, "QuantityCollapser")
150
151	40x	quantities <- matrix(
152	40x	NA,
153	40x	nrow = nrow(quantities_raw),
154	40x	ncol = length(collapser)
155		)
156
157	40x	for (idx in seq_along(collapser)) {
158	27182x	quantities[, idx] <- quantities_raw[,
159	27182x	collapser@indexes[[idx]],
160	27182x	drop = FALSE
161		] \|>
162	27182x	rowMeans()
163		}
164
165	40x	return(quantities)
166		}
167
168		#' Extract Survival Quantities
169		#'
170		#' Utility function to extract generated quantities from a [cmdstanr::CmdStanGQ] object.
171		#' Multiple quantities are generated by default so this is a convenience function to extract
172		#' the desired ones and return them them as a user friendly [posterior::draws_matrix] object
173		#'
174		#' @typed gq: CmdStanGQ
175		#' a [cmdstanr::CmdStanGQ] object created by [generateQuantities()].
176		#' @typed type: character
177		#' quantity to be generated.
178		#' Must be one of `surv`, `haz`, `loghaz`, `cumhaz`, `lm_identity`.
179		#' @keywords internal
180		extract_quantities <- function(
181		gq,
182		type = c("surv", "haz", "loghaz", "cumhaz", "lm_identity")
183		) {
184	41x	type <- match.arg(type)
185	41x	assert_class(gq, "CmdStanGQ")
186	41x	meta <- switch(
187	41x	type,
188	41x	surv = list("log_surv_fit_at_time_grid", exp),
189	41x	cumhaz = list("log_surv_fit_at_time_grid", \(x) -x),
190	41x	haz = list("log_haz_fit_at_time_grid", exp),
191	41x	loghaz = list("log_haz_fit_at_time_grid", identity),
192	41x	lm_identity = list("y_fit_at_time_grid", identity)
193		)
194	41x	result <- gq$draws(meta[[1]], format = "draws_matrix")
195	41x	result_transformed <- meta[[2]](result)
196	41x	cnames <- colnames(result_transformed)
197	41x	colnames(result_transformed) <- gsub(meta[[1]], "quantity", cnames)
198	41x	result_transformed
199		}
200
201
202		#' `Quantities` -> Printable `Character`
203		#'
204		#' Converts [`Quantities`] object into a printable string.
205		#' @inheritParams Quantities-Shared
206		#' @family Quantities
207		#' @keywords internal
208		#' @export
209		as_print_string.Quantities <- function(object, indent = 1, ...) {
210	1x	template <- c(
211	1x	"Quantities Object:",
212	1x	" # of samples = %d",
213	1x	" # of quantities = %d"
214		)
215	1x	pad <- rep(" ", indent) \|> paste(collapse = "")
216	1x	template_padded <- paste(pad, template)
217	1x	sprintf(
218	1x	paste(template_padded, collapse = "\n"),
219	1x	nrow(object),
220	1x	ncol(object)
221		)
222		}
223
224
225		#' @rdname show-object
226		#' @export
227		setMethod(
228		f = "show",
229		signature = "Quantities",
230		definition = function(object) {
231	1x	string <- as_print_string(object)
232	1x	cat("\n", string, "\n\n")
233		}
234		)

1		#' Simulating Joint Longitudinal and Time-to-Event Data
2		#'
3		#' @typed design: list
4		#' a list of [`SimGroup`] objects. See details.
5		#' @typed longitudinal: SimLongitudinal
6		#' object specifying how to simulate the longitudinal data
7		#' @typed survival: SimSurvival
8		#' object specifying how to simulate the survival data
9		#' @typed .silent: flag
10		#' whether to suppress info messages
11		#'
12		#' @slot longitudinal (`data.frame`)\cr the simulated longitudinal data.
13		#' @slot survival (`data.frame`)\cr the simulated survival data.
14		#'
15		#' @details
16		#'
17		#' The `design` argument is used to specify how many distinct groups should be simulated
18		#' including key information such as the number of subjects within the group as well as
19		#' which treatment arm and study the group belongs to. The `design` argument should be a
20		#' list of [`SimGroup`] objects e.g.
21		#' ```
22		#' design = list(
23		#' SimGroup(n = 50, study = "Study-1", arm = "Arm-A"),
24		#' SimGroup(n = 50, study = "Study-1", arm = "Arm-B")
25		#' )
26		#' ```
27		#'
28		#' @name SimJointData-class
29		#' @exportClass SimJointData
30		.SimJointData <- setClass(
31		"SimJointData",
32		slots = list(
33		longitudinal = "data.frame",
34		survival = "data.frame"
35		)
36		)
37
38
39		#' @rdname SimJointData-class
40		#' @export
41		SimJointData <- function(
42		design = list(
43		SimGroup(n = 50, study = "Study-1", arm = "Arm-A"),
44		SimGroup(n = 50, study = "Study-1", arm = "Arm-B")
45		),
46		longitudinal,
47		survival,
48		.silent = FALSE
49		) {
50	24x	assert(
51	24x	all(vapply(design, \(x) is(x, "SimGroup"), logical(1))),
52	24x	msg = "All elements of `design` must be of class `SimGroup`"
53		)
54
55	24x	hazard_evaluation_info <- hazardWindows(survival)
56
57	24x	n_group <- vapply(design, function(x) x@n, numeric(1))
58	24x	arms <- vapply(design, function(x) x@arm, character(1))
59	24x	studies <- vapply(design, function(x) x@study, character(1))
60	24x	n_subjects <- sum(n_group)
61	24x	n_times <- length(hazard_evaluation_info$midpoint)
62
63	24x	sprintf_string <- paste0(
64	24x	"subject_%0",
65	24x	ceiling(log(n_subjects, 10)) + 1,
66	24x	"i"
67		)
68
69	24x	baseline <- dplyr::tibble(
70	24x	subject = sprintf(sprintf_string, seq_len(n_subjects))
71		) \|>
72	24x	dplyr::mutate(
73	24x	arm = factor(rep(arms, times = n_group), levels = unique(arms))
74		) \|>
75	24x	dplyr::mutate(
76	24x	study = factor(
77	24x	rep(studies, times = n_group),
78	24x	levels = unique(studies)
79		)
80		)
81
82	24x	os_baseline <- sampleSubjects(survival, subjects_df = baseline)
83	24x	lm_baseline <- sampleSubjects(longitudinal, subjects_df = baseline)
84
85	24x	lm_dat_no_obvs <- lapply(
86	24x	longitudinal@times,
87	24x	\(time) {
88	4558x	baseline[["time"]] <- time
89	4558x	baseline
90		}
91		) \|>
92	24x	dplyr::bind_rows() \|>
93	24x	dplyr::left_join(lm_baseline, by = c("subject", "study", "arm"))
94
95	24x	lm_dat <- sampleObservations(longitudinal, lm_dat_no_obvs)
96
97	24x	hazard_eval_df <- dplyr::tibble(
98	24x	subject = rep(lm_baseline$subject, each = n_times),
99	24x	arm = rep(lm_baseline$arm, each = n_times),
100	24x	study = rep(lm_baseline$study, each = n_times),
101	24x	midpoint = rep(
102	24x	as.double(hazard_evaluation_info$midpoint),
103	24x	times = n_subjects
104		),
105	24x	time = rep(as.double(hazard_evaluation_info$upper), times = n_subjects),
106	24x	width = rep(as.double(hazard_evaluation_info$width), times = n_subjects)
107		)
108
109	24x	lm_link_dat <- sampleObservations(
110	24x	longitudinal,
111	24x	dplyr::left_join(
112	24x	hazard_eval_df,
113	24x	lm_baseline,
114	24x	by = c("subject", "study", "arm")
115		)
116	24x	)[, c(
117	24x	"subject",
118	24x	"study",
119	24x	"arm",
120	24x	"log_haz_link",
121	24x	"time",
122	24x	"width",
123	24x	"midpoint"
124		)]
125
126	24x	os_eval_df <- lm_link_dat \|>
127	24x	dplyr::left_join(os_baseline, by = c("subject", "study", "arm"))
128
129	24x	withCallingHandlers(
130	24x	os_dat <- sampleObservations(survival, os_eval_df),
131	24x	message = function(e) {
132	8x	if (!.silent) {
133	!	message(e)
134		}
135	8x	invokeRestart("muffleMessage")
136		}
137		)
138
139	24x	lm_dat2 <- lm_dat \|>
140	24x	dplyr::left_join(
141	24x	dplyr::select(os_dat, "subject", os_time = "time"),
142	24x	by = "subject"
143		) \|>
144	24x	dplyr::mutate(observed = (.data$time <= .data$os_time)) \|>
145	24x	dplyr::arrange(dplyr::pick(c("subject", "time")))
146
147	24x	assert_that(
148	24x	length(unique(os_dat$subject)) == length(os_dat$subject),
149	24x	length(os_dat$subject) == n_subjects,
150	24x	all(os_dat$time >= 0),
151	24x	all(os_dat$event %in% c(0, 1)),
152	24x	msg = "Assumptions for the Survival data are not met (please report this issue)"
153		)
154
155	24x	assert_that(
156	24x	nrow(lm_dat2) == n_subjects * length(longitudinal@times),
157	24x	length(unique(lm_dat2$subject)) == n_subjects,
158	24x	msg = "Assumptions for the Longitudinal data are not met (please report this issue)"
159		)
160
161	24x	return(
162	24x	.SimJointData(
163	24x	survival = os_dat,
164	24x	longitudinal = lm_dat2[, c(
165	24x	"subject",
166	24x	"arm",
167	24x	"study",
168	24x	"time",
169	24x	"sld",
170	24x	"observed"
171		)]
172		)
173		)
174		}
175
176		#' @rdname show-object
177		#' @export
178		setMethod(
179		f = "show",
180		signature = "SimJointData",
181		definition = function(object) {
182	1x	x <- sprintf("\nA SimJointData Object\n\n")
183	1x	cat(x)
184	1x	return(object)
185		}
186		)
187
188
189		#' Add PFS events at Tumour Progression to Data
190		#'
191		#' Adds new columns `pfs_time` and `pfs_event` based on observed changes to SLD.
192		#'
193		#' @param object A [SimJointData] object
194		#' @typed relative_threshold: number
195		#' a multiplicative threshold for the change in SLD compared to the `min(SLD)`.
196		#' Default is 1.2 meaning a 20% increase.
197		#' @typed absolute_threshold: number
198		#' an absolute threshold for the change in SLD compared to the minimum.
199		#' Default is 5.
200		#' @typed from_time: number
201		#' Ignore observations before this time for determining SLD minimum.
202		#' @typed observed_after: logical
203		#' If `FALSE` set longitudinal observations after the progression time to
204		#' `observed = FALSE`
205		#' @details
206		#' Both thresholds must be met for a progression to be declared.
207		#'
208		#' @export
209		#' @examples
210		#' data <- SimJointData(
211		#' survival = SimSurvivalExponential(lambda = 1/10),
212		#' longitudinal = SimLongitudinalSteinFojo()
213		#' )
214		#' data <- add_pfs(data)
215		#' data@survival # now has pfs_time and pfs_event columns
216		add_pfs <- function(
217		object,
218		relative_threshold = 1.2,
219		absolute_threshold = 5,
220		from_time = 0,
221		observed_after = FALSE
222		) {
223	3x	assert_class(object, "SimJointData")
224
225	3x	pd_times <- object@longitudinal \|>
226	3x	dplyr::filter(.data$time >= from_time) \|>
227	3x	dplyr::mutate(
228	3x	min_sld = cummin(.data$sld),
229	3x	is_pd = .data$sld >=
230	3x	pmax(
231	3x	.data$min_sld * relative_threshold,
232	3x	.data$min_sld + absolute_threshold
233		) &
234	3x	.data$observed,
235	3x	pd_time = min(.data$time[.data$is_pd], Inf),
236	3x	.by = "subject"
237		) \|>
238	3x	dplyr::select("subject", "pd_time") \|>
239	3x	dplyr::slice_head(by = "subject")
240
241	3x	if (isFALSE(observed_after)) {
242	2x	object@longitudinal <- object@longitudinal \|>
243	2x	dplyr::left_join(pd_times, by = "subject") \|>
244	2x	dplyr::mutate(
245	2x	observed = dplyr::if_else(
246	2x	.data$time > .data$pd_time,
247	2x	FALSE,
248	2x	.data$observed
249		),
250	2x	pd_time = NULL
251		)
252		}
253
254	3x	object@survival <-
255	3x	object@survival \|>
256	3x	dplyr::left_join(pd_times, by = "subject") \|>
257	3x	dplyr::mutate(
258	3x	pfs_time = pmin(.data$time, .data$pd_time, na.rm = TRUE),
259	3x	pfs_event = dplyr::if_else(
260	3x	.data$pfs_time < .data$time,
261	3x	1,
262	3x	.data$event
263		),
264	3x	pd_time = NULL
265		)
266	3x	object
267		}
268
269
270		#' Cut Study Data
271		#' @param object A [SimJointData] object
272		#' @typed cut_time: numeric
273		#' A vector of cut off times, either length 1 for all patients or
274		#' `nrow(object@survival)` for a time per patient.
275		#' @details
276		#' All observations after this time are remove. Survival is censored at this time and any longitudinal
277		#' values are removed.
278		#' @export
279		#' @examples
280		#' data <- SimJointData(
281		#' survival = SimSurvivalExponential(lambda = 1/10),
282		#' longitudinal = SimLongitudinalSteinFojo()
283		#' )
284		#' data <- cut_data(data, 5)
285		#' data@survival
286		#' # Now max time is 5
287		#' max(data@survival$time)
288		cut_data <- function(object, cut_time) {
289	3x	assert_class(object, "SimJointData")
290	3x	check_len <- if (length(cut_time) > 1) nrow(object@survival) else 1
291	3x	assert_numeric(cut_time, lower = 0, len = check_len)
292
293	2x	object@survival <- object@survival \|>
294	2x	dplyr::mutate(
295	2x	cut_time = cut_time,
296	2x	event = dplyr::if_else(.data$time < .data$cut_time, .data$event, 0),
297	2x	time = pmin(.data$cut_time, .data$time)
298		)
299	2x	if (all(c("pfs_event", "pfs_time") %in% colnames(object@survival))) {
300	!	object@survival <- object@survival \|>
301	!	dplyr::mutate(
302	!	pfs_event = dplyr::if_else(
303	!	.data$pfs_time < .data$cut_time,
304	!	.data$pfs_event,
305	!	0
306		),
307	!	pfs_time = pmin(.data$cut_time, .data$pfs_time)
308		)
309		}
310
311	2x	object@longitudinal <- object@longitudinal \|>
312	2x	dplyr::left_join(
313	2x	dplyr::select(object@survival, "subject", "cut_time"),
314	2x	by = "subject"
315		) \|>
316	2x	dplyr::filter(.data$time <= .data$cut_time) \|>
317	2x	dplyr::mutate(cut_time = NULL)
318
319	2x	object@survival$cut_time <- NULL
320
321	2x	object
322		}

1		#' @include DataSurvival.R
2		#' @include DataLongitudinal.R
3		#' @include DataSubject.R
4		NULL
5
6
7		#' Re-used documentation for `DataJoint`
8		#'
9		#' @typed object: DataJoint
10		#' Survival and Longitudinal Data.
11		#' @typed x: DataJoint
12		#' Survival and Longitudinal Data.
13		#' @param ... Not Used.
14		#'
15		#' @name DataJoint-Shared
16		#' @keywords internal
17		NULL
18
19		setClassUnion("DataLongitudinal_or_NULL", c("DataLongitudinal", "NULL"))
20		setClassUnion("DataSurvival_or_NULL", c("DataSurvival", "NULL"))
21
22
23		# DataJoint-class ----
24
25		#' @title
26		#' Joint Data Object and Constructor Function
27		#'
28		#' @description
29		#' The `DataJoint` class handles combining data from a [`DataSurvival`] object and a
30		#' [`DataLongitudinal`] object.
31		#'
32		#' @slot subject (`DataSubject`)\cr See Argument for details.
33		#' @slot survival (`DataSurvival`)\cr See Argument for details.
34		#' @slot longitudinal (`DataLongitudinal`)\cr See Argument for details.
35		#'
36		#' @family DataObjects
37		#' @family DataJoint
38		#' @export DataJoint
39		#' @exportClass DataJoint
40		.DataJoint <- setClass(
41		Class = "DataJoint",
42		representation = list(
43		subject = "DataSubject",
44		survival = "DataSurvival_or_NULL",
45		longitudinal = "DataLongitudinal_or_NULL"
46		)
47		)
48
49		#' @typed subject: DataSubject
50		#' object created by [DataSubject()].
51		#' @typed survival: DataSurvival
52		#' object created by [DataSurvival()].
53		#' @typed longitudinal: DataLongitudinal
54		#' object created by [DataLongitudinal()].
55		#' @rdname DataJoint-class
56		DataJoint <- function(subject, survival = NULL, longitudinal = NULL) {
57	34x	subject_suited <- harmonise(subject)
58	33x	vars <- extractVariableNames(subject)
59	33x	subject_var <- vars$subject
60	33x	subject_ord <- levels(as.data.frame(subject_suited)[[vars$subject]])
61
62	33x	survival_suited <- harmonise(
63	33x	survival,
64	33x	subject_var = subject_var,
65	33x	subject_ord = subject_ord
66		)
67
68	30x	longitudinal_suited <- harmonise(
69	30x	longitudinal,
70	30x	subject_var = subject_var,
71	30x	subject_ord = subject_ord
72		)
73
74	27x	.DataJoint(
75	27x	subject = subject_suited,
76	27x	survival = survival_suited,
77	27x	longitudinal = longitudinal_suited
78		)
79		}
80
81
82		setValidity(
83		Class = "DataJoint",
84		method = function(object) {
85		vars <- extractVariableNames(object@subject)
86		subject_var <- vars$subject
87		subject_ord <- as.character(as.data.frame(object@subject)[[
88		vars$subject
89		]])
90		if (!is.null(object@survival)) {
91		survival_df <- as.data.frame(object@survival)
92		if (!subject_var %in% names(survival_df)) {
93		return(sprintf(
94		"Unable to find `%s` in `survival`",
95		sujbect_var
96		))
97		}
98		if (!all(survival_df[[subject_var]] %in% subject_ord)) {
99		return(
100		"There are subjects in `survival` that are not in `subject`"
101		)
102		}
103		if (
104		!nrow(survival_df) == length(unique(survival_df[[subject_var]]))
105		) {
106		return("There are duplicate subjects in `survival`")
107		}
108		}
109		if (!is.null(object@longitudinal)) {
110		long_df <- as.data.frame(object@longitudinal)
111		if (!subject_var %in% names(long_df)) {
112		return(sprintf(
113		"Unable to find `%s` in `longitudinal`",
114		sujbect_var
115		))
116		}
117		if (!all(long_df[[subject_var]] %in% subject_ord)) {
118		return(
119		"There are subjects in `longitudinal` that are not in `subject`"
120		)
121		}
122		}
123		subject_df <- as.data.frame(object@subject)
124		if (!subject_var %in% names(subject_df)) {
125		return(sprintf("Unable to find `%s` in `subject`", sujbect_var))
126		}
127		if (!nrow(subject_df) == length(unique(subject_df[[subject_var]]))) {
128		return("There are duplicate subjects in `subject`")
129		}
130		return(TRUE)
131		}
132		)
133
134
135		# DataJoint-as.list ----
136
137		#' Data Object -> `list`
138		#'
139		#' @typed object: "`DataSubject` or `DataLongitudinal` or `DataSurvival`"
140		#' data object to convert to a `list`.
141		#' @typed x: "`DataSubject` or `DataLongitudinal` or `DataSurvival`"
142		#' data object to convert to a `list`.
143		#' @typed subject_var: character
144		#' the name of the variable
145		#' containing the subject identifier.
146		#' @param ... not used.
147		#'
148		#' @description
149		#' Coerces a data object into a `list` of data components required
150		#' for fitting a [`JointModel`]. See the "Extending jmpost" vignette for more details.
151		#'
152		#' @name as_stan_list.DataObject
153		#' @family as_stan_list
154		#' @family DataJoint
155		#' @export
156		as_stan_list.DataJoint <- function(object, ...) {
157	333x	vars <- extractVariableNames(object@subject)
158	333x	subject_var <- vars$subject
159	333x	as_stan_list(object@subject) \|>
160	333x	append(as_stan_list(object@survival)) \|>
161	333x	append(as_stan_list(
162	333x	object@longitudinal,
163	333x	subject_var = subject_var
164		))
165		}
166
167		#' @rdname as_stan_list.DataObject
168		#' @export
169		as.list.DataJoint <- function(x, ...) {
170	276x	as_stan_list(x, ...)
171		}
172
173
174		#' Subsetting `DataJoint` as a `data.frame`
175		#'
176		#' @typed x: DataJoint
177		#' object created by [DataJoint()].
178		#' @typed subjects: "`character` or `list`"
179		#' subjects that you wish to subset the `data.frame`
180		#' to contain. See details.
181		#' @param ... Not used.
182		#'
183		#' @description
184		#'
185		#' Coerces the object into a `data.frame` containing just event times and status
186		#' filtering for specific subjects If `subjects` is a list then an additional variable `group` will be added
187		#' onto the dataset specifying which group the row belongs to.
188		#'
189		#' @examples
190		#' \dontrun{
191		#' subjects <- c("SUB1", "SUB2", "SUB3", "SUB4")
192		#' subset(x, subjects)
193		#'
194		#' groups <- list(
195		#' "g1" = c("SUB1", "SUB3", "SUB4"),
196		#' "g2" = c("SUB2", "SUB3")
197		#' )
198		#' subset(x, groups)
199		#' }
200		#' @family DataJoint
201		#' @export
202		subset.DataJoint <- function(x, subjects, ...) {
203	2x	data <- as.list(x)
204	2x	dat <- data.frame(
205	2x	time = data[["event_times"]],
206	2x	event = as.numeric(
207	2x	seq_along(data[["event_times"]]) %in% data[["subject_event_index"]]
208		),
209	2x	subject = names(data[["subject_to_index"]])
210		)
211	2x	subset_and_add_grouping(dat, subjects)
212		}
213
214
215		#' `subset_and_add_grouping`
216		#'
217		#' @typed dat: data.frame
218		#' must have a column called `subject` which corresponds to the
219		#' values passed to `groupings`.
220		#' @typed groupings: "`character` or `list`"
221		#' subjects that you wish to subset the dataset
222		#' to contain. If `groupings` is a list then an additional variable `group` will be added
223		#' onto the dataset specifying which group the row belongs to.
224		#'
225		#' @details
226		#' Example of usage
227		#' ```
228		#' subjects <- c("SUB1", "SUB2", "SUB3", "SUB4")
229		#' subset_and_add_grouping(dat, subjects)
230		#'
231		#' groups <- list(
232		#' "g1" = c("SUB1", "SUB3", "SUB4"),
233		#' "g2" = c("SUB2", "SUB3")
234		#' )
235		#' subset_and_add_grouping(dat, groups)
236		#' ```
237		#'
238		#' @keywords internal
239		subset_and_add_grouping <- function(dat, groupings) {
240	8x	groupings <- decompose_subjects(groupings, dat$subject)$groups
241	5x	dat_subset_list <- lapply(
242	5x	seq_along(groupings),
243	5x	\(i) {
244	13x	dat_reduced <- dat[dat$subject %in% groupings[[i]], , drop = FALSE]
245	13x	dat_reduced[["group"]] <- names(groupings)[[i]]
246	13x	dat_reduced
247		}
248		)
249	5x	x <- Reduce(rbind, dat_subset_list)
250	5x	row.names(x) <- NULL
251	5x	x
252		}
253
254
255		#' Extract Observed Longitudinal Values
256		#'
257		#' Utility function to extract the observed longitudinal values from a [`DataJoint`] object
258		#' @typed object: DataJoint
259		#' data used to fit a [`JointModel`].
260		#' @return A data.frame with the following columns
261		#' - `subject` (`character`)\cr The subject identifier
262		#' - `time` (`numeric`)\cr The time at which the observation occurred
263		#' - `Yob` (`numeric`)\cr The observed value
264		#' @keywords internal
265		extract_observed_values <- function(object) {
266	2x	assert_class(object, "DataJoint")
267	2x	data <- as.list(object)
268	2x	x <- data.frame(
269	2x	subject = names(data$subject_to_index)[data$subject_tumour_index],
270	2x	time = data$tumour_time,
271	2x	Yob = data$tumour_value
272		)
273	2x	row.names(x) <- NULL
274	2x	x
275		}
276
277		#' @rdname show-object
278		#' @export
279		setMethod(
280		f = "show",
281		signature = "DataJoint",
282		definition = function(object) {
283	3x	string_survival <- if (is.null(object@survival)) {
284	1x	" Survival-Data Object:\n Not Specified"
285		} else {
286	2x	as_print_string(object@survival, indent = 5)
287		}
288
289	3x	string_longitudinal <- if (is.null(object@longitudinal)) {
290	1x	" Longitudinal-Data Object:\n Not Specified"
291		} else {
292	2x	as_print_string(object@longitudinal, indent = 5)
293		}
294
295	3x	template <- c(
296	3x	"Joint-Data Object Containing:",
297		"",
298	3x	as_print_string(object@subject, indent = 5),
299		"",
300	3x	string_survival,
301		"",
302	3x	string_longitudinal
303		)
304	3x	cat("\n", paste(template, collapse = "\n"), "\n\n")
305		}
306		)

1		#' Row Numbers of Data with Missing Variables
2		#'
3		#' @typed df: data.frame
4		#' input data.
5		#' @typed formula: "`formula` or `NULL`"
6		#' which variables to inspect for missingness, if `NULL`
7		#' all variables are considered.
8		#'
9		#' @returns Numeric vector specifying which rows contain at least 1 missing observation
10		#' in any of the inspected variables.
11		#'
12		#' @keywords internal
13		get_missing_rownumbers <- function(df, formula = NULL) {
14	507x	if (is.null(formula)) {
15	!	formula <- ~.
16		}
17	507x	mdf <- stats::model.frame(formula, data = df, na.action = stats::na.pass)
18	507x	which(!stats::complete.cases(mdf))
19		}
20
21		#' Remove Rows with Missing Variables
22		#'
23		#' Removes any rows from a data set that contain missing values in the inspected
24		#' variables. Allows users to specify which variables to inspect for missing values
25		#' based on either a formula or a character vector of variable names.
26		#'
27		#' @typed data: data.frame
28		#' input data.
29		#' @typed formula: "`formula` or `NULL`"
30		#' which variables to inspect for missingness.
31		#' @typed extra_vars: character
32		#' additional variables to inspect for missingness.
33		#'
34		#' @returns The `data` after removing observations that contain missing values in the required variables.
35		#' Note that additional variables not listed in `formula` or `extra_vars` are not dropped and may
36		#' still contain missing values.
37		#'
38		#' @keywords internal
39		remove_missing_rows <- function(data, formula, extra_vars = NULL) {
40	506x	if (!is.null(extra_vars)) {
41	1x	extra_vars <- paste(extra_vars, collapse = " + ")
42	1x	formula_update_string <- paste0(". ~ . + ", extra_vars)
43	1x	formula <- stats::update(formula, formula_update_string)
44		}
45
46	506x	missing_rows <- get_missing_rownumbers(data, formula)
47
48	506x	if (length(missing_rows) == 0) {
49	504x	return(data)
50		}
51	2x	message(sprintf(
52	2x	"Note that %d observations were removed as one of more required variables contained missing values",
53	2x	length(missing_rows)
54		))
55	2x	data_reduced <- data[-missing_rows, ]
56	2x	rownames(data_reduced) <- NULL
57	2x	data_reduced
58		}
59
60		#' Replicate Single Values in a List
61		#'
62		#' @typed initial_values: list
63		#' initial values with names.
64		#' @typed sizes: list
65		#' each size corresponds to an element in `initial_values`,
66		#' matched by the names. An attribute `array` must be attached to each element,
67		#' see [replace_with_lookup()].
68		#'
69		#' @returns A named list of values, with any single values in the `initial_values` list
70		#' replicated according to the corresponding values in the `sizes` list.
71		#' Even when the size is 1, the value is passed as an `array` if the corresponding
72		#' attribute is `TRUE` in `sizes`.
73		#'
74		#' @note The resulting list has the same names as the original lists.
75		#'
76		#' @keywords internal
77		expand_initial_values <- function(initial_values, sizes) {
78	31x	assert_that(
79	31x	is.list(initial_values),
80	31x	msg = "`initial_values` must be a list"
81		)
82	31x	assert_that(
83	31x	is.list(sizes),
84	31x	msg = "`sizes` must be a list"
85		)
86	31x	assert_that(
87	31x	all(names(sizes) %in% names(initial_values)),
88	31x	all(names(initial_values) %in% names(sizes)),
89	31x	msg = "`initial_values` and `sizes` must have identical names"
90		)
91
92	31x	for (name in names(initial_values)) {
93		# Check for single values and replicate them according to sizes.
94	217x	if (length(initial_values[[name]]) == 1) {
95	214x	initial_values[[name]] <- rep(initial_values[[name]], sizes[[name]])
96		}
97		# Check for array handling.
98	217x	needs_array <- attr(sizes[[name]], "array")
99	217x	assert_that(
100	217x	is.flag(needs_array),
101	217x	msg = "each sizes element must have array flag attribute"
102		)
103	217x	if (needs_array) {
104	161x	initial_values[[name]] <- as.array(initial_values[[name]])
105		}
106		}
107
108		# Check that each element of initial_values has the same length as specified in sizes.
109	31x	for (name in names(initial_values)) {
110	217x	assert_that(
111	217x	length(initial_values[[name]]) == sizes[[name]],
112	217x	msg = "length of element in `initial_values` does not match specified size"
113		)
114		}
115
116	31x	initial_values
117		}
118
119		#' Replace Character Size by Looked Up Numbers
120		#'
121		#' @typed sizes: list
122		#' may include character elements that correspond to
123		#' names in the data list.
124		#' @typed data: list
125		#' data containing numeric values.
126		#'
127		#' @returns A list of sizes with character elements in `sizes`
128		#' replaced by their corresponding numeric values in `data`.
129		#'
130		#' @details An attribute `array` for each returned list element indicates
131		#' whether the parameter needs to be handled
132		#' as an array. This is the case when the size is larger than 1, or when
133		#' the size was looked up in the `data`, because in that case it is flexible
134		#' and hence is handled as an array in the Stan code.
135		#'
136		#' @note Each element in the final list of sizes must be a single number.
137		#'
138		#' @keywords internal
139		replace_with_lookup <- function(sizes, data) {
140	21x	assert_that(is.list(sizes), msg = "`sizes` must be a list")
141	21x	assert_that(is.list(data), msg = "`data` must be a list")
142
143	21x	for (idx in seq_along(sizes)) {
144	144x	val <- sizes[[idx]]
145	144x	if (is.character(val)) {
146	104x	assert_that(
147	104x	length(val) == 1,
148	104x	msg = "character elements of `sizes` must be strings"
149		)
150	104x	assert_that(
151	104x	val %in% names(data),
152	104x	msg = sprintf("`%s` is not available in `data`", val)
153		)
154	104x	new_val <- data[[val]]
155	104x	assert_that(
156	104x	is.number(new_val),
157	104x	msg = "Selected values from data must be single numbers"
158		)
159	103x	sizes[[idx]] <- structure(new_val, array = TRUE)
160		} else {
161	40x	assert_that(
162	40x	is.number(val),
163	40x	msg = "Existing values in sizes must be single numbers"
164		)
165	39x	sizes[[idx]] <- structure(val, array = val > 1)
166		}
167		}
168	19x	sizes
169		}
170
171		#' Obtain Median and Credible Intervals from MCMC samples
172		#'
173		#' @typed samples: matrix
174		#' with samples in rows and parameters in columns.
175		#' @typed level: number
176		#' credibility level to use for the credible intervals.
177		#'
178		#' @returns A `data.frame` with columns `median`, `lower` and `upper`.
179		#' @keywords internal
180		samples_median_ci <- function(samples, level = 0.95) {
181	41x	assert_that(is.matrix(samples))
182	41x	assert_that(is.number(level), level < 1, level > 0)
183
184	41x	samples_median <- apply(samples, MARGIN = 2L, FUN = stats::median)
185	41x	probs <- c((1 - level) / 2, (1 + level) / 2)
186	41x	samples_ci <- t(apply(
187	41x	samples,
188	41x	MARGIN = 2L,
189	41x	FUN = stats::quantile,
190	41x	probs = probs
191		))
192	41x	colnames(samples_ci) <- c("lower", "upper")
193	41x	as.data.frame(cbind(
194	41x	median = samples_median,
195	41x	samples_ci
196		))
197		}
198
199
200		#' `decorated_render`
201		#'
202		#' Simple wrapper around [jinjar::render()] that provides some additional default
203		#' variables about the system (avoids each call to jinjar having to specify them)
204		#' @param ... Arguments passed onto [jinjar::render()]
205		#' @returns See [jinjar::render()]
206		#' @keywords internal
207		decorated_render <- function(...) {
208	474x	jinjar::render(
209		...,
210	474x	machine_double_eps = 0,
211	474x	machine_double_neg_eps = 0
212		)
213		}
214
215
216		is_windows <- function() {
217	58x	sysname <- Sys.info()["sysname"]
218	58x	return(sysname == "Windows")
219		}
220
221		#' `validate_time_grid`
222		#'
223		#' Validate that the provided time grid is:
224		#' - finite
225		#' - numeric
226		#' - non-missing
227		#' - sorted
228		#' - unique
229		#'
230		#' @typed time_grid: numeric
231		#' A vector of times which quantities will be
232		#' evaluated at.
233		#'
234		#' @keywords internal
235		validate_time_grid <- function(time_grid) {
236	88x	assert_that(
237	88x	!any(is.na(time_grid)),
238	88x	is.numeric(time_grid),
239	88x	!is.null(time_grid),
240	88x	!is.unsorted(time_grid),
241	88x	!any(duplicated(time_grid)),
242	88x	all(is.finite(time_grid)),
243	88x	msg = "`time_grid` needs to be finite, sorted, unique valued numeric vector"
244		)
245	84x	invisible(time_grid)
246		}
247
248
249		#' `expand_subjects`
250		#'
251		#' This function checks and expands a given subjects vector.
252		#' The input vector must be unique and contain only values
253		#' as specified by `all_subjects`
254		#'
255		#' @typed subjects: "`character` or `NULL`"
256		#' Character vector representing the subjects.
257		#' If NULL, it will be set to the value of `all_subjects`.
258		#' @typed all_subjects: character
259		#' Character vector representing all possible subjects.
260		#' @return Returns the expanded `subjects` vector.
261		#' @keywords internal
262		expand_subjects <- function(subjects, all_subjects) {
263	38x	assert_that(
264	38x	is.character(all_subjects),
265	38x	msg = "`all_subjects` must be a character vector"
266		)
267	38x	if (is.null(subjects)) {
268	3x	subjects <- unique(all_subjects)
269		}
270	38x	assert_that(
271	38x	is.character(subjects),
272	38x	all(subjects %in% all_subjects),
273	38x	!any(duplicated(subjects)),
274	38x	msg = "`subjects` should be a unique character vector containing only values from the original df"
275		)
276	30x	return(subjects)
277		}
278
279
280		#' Decompose subjects into Relevant Components
281		#'
282		#' This function takes in a character vector or list of subjects and decomposes it into a
283		#' structured format.
284		#'
285		#' The primary use of this function is to correctly setup indexing variables for
286		#' predicting survival quantities (see [SurvivalQuantities()])
287		#'
288		#' @typed subjects: "`character` or `list`"
289		#' subject identifiers. If `NULL` will be set to `all_subjects`.
290		#'
291		#' @typed all_subjects: character
292		#' the set of allowable subject identifiers.
293		#' Will cause an error if any value of `subjects` is not in this vector.
294		#'
295		#' @return A list containing three components:
296		#' - `groups`: (`list`)\cr each element of the list is a character vector
297		#' specifying which subjects belong to a given "group" where the "group" is the element name
298		#' - `unique_values`: (`character`)\cr vector of the unique subjects within `subjects`
299		#' - `indexes`: (`list`)\cr each element is a named and is a numeric index vector
300		#' that maps the values of `grouped` to `unique_values`
301		#' @examples
302		#' \dontrun{
303		#' result <- decompose_subjects(c("A", "B"), c("A", "B", "C", "D"))
304		#' result <- decompose_subjects(
305		#' list("g1" = c("A", "B"), "g2" = c("B", "C")),
306		#' c("A", "B", "C", "D")
307		#' )
308		#' }
309		#' @seealso [expand_subjects()], [SurvivalQuantities()]
310		#' @keywords internal
311		decompose_subjects <- function(subjects, all_subjects) {
312	13x	if (is.character(subjects) \|\| is.null(subjects)) {
313	7x	subjects <- expand_subjects(subjects, all_subjects)
314	4x	names(subjects) <- subjects
315	4x	subjects <- as.list(subjects)
316		}
317	10x	subjects <- lapply(
318	10x	subjects,
319	10x	expand_subjects,
320	10x	all_subjects = all_subjects
321		)
322	8x	assert_that(
323	8x	is.list(subjects),
324	8x	length(unique(names(subjects))) == length(subjects),
325	8x	all(vapply(subjects, is.character, logical(1)))
326		)
327	8x	subjects_vec_unordered <- unique(unlist(subjects))
328	8x	subjects_vec <- subjects_vec_unordered[order(subjects_vec_unordered)]
329	8x	subjects_lookup <- stats::setNames(seq_along(subjects_vec), subjects_vec)
330	8x	subjects_index <- lapply(
331	8x	subjects,
332	8x	\(x) {
333	22x	z <- subjects_lookup[x]
334	22x	names(z) <- NULL
335	22x	z
336		}
337		)
338	8x	list(
339	8x	groups = subjects,
340	8x	unique_values = subjects_vec,
341	8x	indexes = subjects_index
342		)
343		}
344
345		is_cmdstanr_available <- function() {
346	4x	requireNamespace("cmdstanr", quietly = TRUE)
347		}
348
349
350		is_connection <- function(obj) {
351	!	inherits(obj, "connection")
352		}

1		#' Re-used documentation for `RandomEffectQuantities`
2		#'
3		#' @typed x: RandomEffectQuantities
4		#' generated quantities.
5		#' @typed object: RandomEffectQuantities
6		#' generated quantities.
7		#' @typed conf.level: numeric
8		#' confidence level of the interval.
9		#' @param ... not used.
10		#'
11		#' @keywords internal
12		#' @name RandomEffectQuantities-Shared
13		NULL
14
15
16		#' Random Effects Quantities Container
17		#'
18		#' A simple wrapper around a `matrix` to store required metadata for patient level
19		#' random effects data
20		#'
21		#' @typed quantities: matrix
22		#' of random effects values.
23		#' @typed subject: character
24		#' labels specifying which subjects the values belong to.
25		#' @typed parameter: character
26		#' labels specifying which parameter the value is.
27		#'
28		#' @slot quantities (`matrix`)\cr See Arguments for details.
29		#' @slot subject (`numeric`)\cr See Arguments for details.
30		#' @slot parameter (`character`)\cr See Arguments for details.
31		#'
32		#' @details
33		#' Each row of the matrix represents a sample and each column represents a distinct subject
34		#' specific parameter.
35		#' As such the number of columns in the matrix should equal the length of `subject` and `parameter`
36		#' which provide metadata for who the parameter corresponds to as well as which parameter it is.
37		#'
38		#' @keywords internal
39		#' @name RandomEffectQuantities-class
40		#' @family RandomEffectQuantities
41		.RandomEffectQuantities <- setClass(
42		"RandomEffectQuantities",
43		slots = list(
44		"quantities" = "matrix",
45		"subject" = "character",
46		"parameter" = "character"
47		)
48		)
49		#' @rdname RandomEffectQuantities-class
50		RandomEffectQuantities <- function(quantities, subject, parameter) {
51	1x	.RandomEffectQuantities(
52	1x	quantities = quantities,
53	1x	subject = subject,
54	1x	parameter = parameter
55		)
56		}
57
58		setValidity(
59		Class = "RandomEffectQuantities",
60		method = function(object) {
61		if (length(object@subject) != ncol(object@quantities)) {
62		return(
63		"Length of `subject` must be equal to the number of columns in `quantities`"
64		)
65		}
66		if (length(object@parameter) != ncol(object@quantities)) {
67		return(
68		"Length of `parameter` must be equal to the number of columns in `quantities`"
69		)
70		}
71		TRUE
72		}
73		)
74
75
76		#' `RandomEffectQuantities` -> Printable `Character`
77		#'
78		#' Converts [`RandomEffectQuantities`] object into a printable string.
79		#' @inheritParams RandomEffectQuantities-Shared
80		#' @typed indent: numeric
81		#' the number of spaces to indent the string by.
82		#' @family RandomEffectQuantities
83		#' @keywords internal
84		#' @export
85		as_print_string.RandomEffectQuantities <- function(object, indent = 1, ...) {
86	!	parameter_string <- paste0(" ", unique(object@parameter))
87	!	template <- c(
88	!	"RandomEffectQuantities Object:",
89	!	" # of samples = %d",
90	!	" # of unique subjects = %d",
91	!	" For parameters:",
92	!	parameter_string
93		)
94	!	pad <- rep(" ", indent) \|> paste(collapse = "")
95	!	template_padded <- paste(pad, template)
96	!	sprintf(
97	!	paste(template_padded, collapse = "\n"),
98	!	nrow(object@quantities),
99	!	length(unique(object@subject))
100		)
101		}
102
103
104		#' @rdname show-object
105		#' @export
106		setMethod(
107		f = "show",
108		signature = "RandomEffectQuantities",
109		definition = function(object) {
110	!	string <- as_print_string(object)
111	!	cat("\n", string, "\n\n")
112		}
113		)
114
115
116		#' `RandomEffectQuantities` -> `data.frame`
117		#'
118		#' Returns a `data.frame` of the subject-level random effect parameter samples.
119		#'
120		#' @inheritParams RandomEffectQuantities-Shared
121		#'
122		#' @keywords internal
123		#' @family RandomEffectQuantities
124		#' @export
125		as.data.frame.RandomEffectQuantities <- function(x, ...) {
126	1x	data.frame(
127	1x	subject = rep(x@subject, each = nrow(x@quantities)),
128	1x	parameter = rep(x@parameter, each = nrow(x@quantities)),
129	1x	values = as.vector(x@quantities)
130		)
131		}
132
133
134		#' summary
135		#'
136		#' @description
137		#' This method returns a summary statistic `data.frame` of the random effect parameters
138		#'
139		#' @inheritParams RandomEffectQuantities-Shared
140		#'
141		#' @returns
142		#' A `data.frame` with the following variables:
143		#' - `subject` (`character`) \cr the subject identifier.
144		#' - `parameter` (`character`) \cr the parameter identifier.
145		#' - `median` (`numeric`) \cr the median value of the quantity.
146		#' - `lower` (`numeric`) \cr the lower CI value of the quantity.
147		#' - `upper` (`numeric`) \cr the upper CI value of the quantity.
148		#'
149		#' @keywords internal
150		#' @family RandomEffectQuantities
151		#' @export
152		summary.RandomEffectQuantities <- function(object, conf.level = 0.95, ...) {
153	1x	quantities_summarised <- samples_median_ci(
154	1x	object@quantities,
155	1x	level = conf.level
156		)
157
158	1x	quantities_summarised$subject <- object@subject
159	1x	quantities_summarised$parameter <- object@parameter
160	1x	quantities_summarised[, c(
161	1x	"subject",
162	1x	"parameter",
163	1x	"median",
164	1x	"lower",
165	1x	"upper"
166		)]
167		}
168
169
170		#' Extract Random Effects Samples from a Longitudinal Model
171		#'
172		#' Helper function to extract subject-level random effects samples from the longitudinal
173		#' sub-model of a joint model samples object.
174		#'
175		#' @typed object: JointModelSamples
176		#' samples as drawn from a Joint Model.
177		#' @family RandomEffectQuantities
178		#' @family JointModelSamples
179		#' @export
180		LongitudinalRandomEffects <- function(object) {
181	1x	assert_class(object, "JointModelSamples")
182
183	1x	subject_indexes <- as.list(object@data)$subject_to_index
184	1x	random_effects_names <- getRandomEffectsNames(object@model)
185	1x	expanded <- expand.grid(
186	1x	parameter_long = random_effects_names,
187	1x	subject_indexes = subject_indexes
188		)
189	1x	expanded$subject <- names(subject_indexes)[expanded$subject_indexes]
190	1x	expanded$parameter <- names(random_effects_names)[expanded$parameter_long]
191	1x	stan_parameter_names <- sprintf(
192	1x	"%s[%i]",
193	1x	expanded$parameter_long,
194	1x	expanded$subject_indexes
195		)
196	1x	draw_matrix <- posterior::as_draws_matrix(object@results$draws(
197	1x	stan_parameter_names
198		))
199	1x	class(draw_matrix) <- "matrix"
200	1x	rownames(draw_matrix) <- NULL
201	1x	colnames(draw_matrix) <- NULL
202
203	1x	RandomEffectQuantities(
204	1x	draw_matrix,
205	1x	subject = expanded$subject,
206	1x	parameter = expanded$parameter
207		)
208		}

1		#' Simulate Patients from Posterior Predictive Distribution
2		#' @param object A [JointModelSamples] object
3		#' @param newdata A data frame containing data in the same format as
4		#' the `object@data@survival@data`. Importantly, it should contain the same covariates and factor levels
5		#' as the variables used in the survival formula `object@data@survival@formula` and
6		#' the same columns used for `study`, `id`, and `arm`.
7		#' @param ... Unused.
8		#' @param times Vector of times to simulate SLD for all patients.
9		#' @param jitter_var Vector of variances to add noise to the observed SLD `times`. The first value is for any times
10		#' less than 0 and the second for any times after 0. All positive (negative) times will remain positive (negative).
11		#' Jitter values are generated from a normal distribution with mean 0 and the given variances.
12		#' @typed time_max: number
13		#' the maximum time to simulate to.
14		#' @typed time_step: number
15		#' the time interval between evaluating the log-hazard function.
16		#' @typed lambda_censor: number
17		#' the censoring rate, as the parameter of an exponential distribution.
18		#' @param scaled_variance Should variance be scaled by the expected value. Must be set the same as was used for
19		#' model fitting.
20		#' @param seed Ignored.
21		#' @param nsim Ignored.
22		#' @details Simulates a set of patients based on the covariates of those
23		#' used in the model fit or from `newdata`, which must contain the
24		#' same column names and factor levels.
25		#'
26		#' @importFrom stats simulate
27		#' @export
28		simulate.JointModelSamples <- function(
29		object,
30		nsim = NULL,
31		seed = NULL,
32		newdata = NULL,
33		times = c(-2, 0, 10, 50, 100),
34		jitter_var = c(0, 0),
35		time_max = 2000,
36		time_step = 1,
37		lambda_censor = 1 / 3000,
38		scaled_variance = TRUE,
39		...
40		) {
41	!	subj_data <- if (is.null(newdata)) {
42	!	dplyr::left_join(
43	!	object@data@subject@data[, c(
44	!	object@data@subject@subject,
45	!	object@data@subject@arm,
46	!	object@data@subject@study
47		)],
48	!	object@data@survival@data[, c(
49	!	object@data@subject@subject,
50	!	all.vars(delete.response(terms(object@data@survival@formula)))
51		)],
52	!	by = object@data@subject@subject
53		)
54		} else {
55	!	newdata
56		}
57
58	!	subject_data <- DataSubject(
59	!	subj_data,
60	!	subject = object@data@subject@subject,
61	!	arm = object@data@subject@arm,
62	!	study = object@data@subject@study
63		)
64
65	!	n_patients <- nrow(subject_data@data)
66
67	!	requiredVars <- list(
68	!	longitudinal = lapply(
69	!	object@model@survival@parameters@parameters,
70	!	function(x) x@name
71		),
72	!	survival = lapply(
73	!	object@model@longitudinal@parameters@parameters,
74	!	function(x) x@name
75		),
76	!	link = lapply(object@model@link@components, function(x) x@key)
77		)
78
79	!	draws <- object@results$draws(
80	!	variables = unlist(requiredVars),
81	!	format = "draws_matrix"
82		)
83	!	draw_id <- sample.int(nrow(draws), n_patients, replace = FALSE)
84
85	!	long_models <- list()
86	!	surv_models <- list()
87	!	for (i in seq.int(n_patients)) {
88	!	draw <- draws[draw_id[i], ]
89	!	long_models[[i]] <- createLongitudinalSimObject(
90	!	object@model@longitudinal,
91	!	draw,
92	!	times = add_jitter(times, jitter_var = jitter_var),
93	!	scaled_variance = scaled_variance
94		)
95	!	surv_models[[i]] <- createSurvivalSimObject(
96	!	object@model@survival,
97	!	draw,
98	!	lambda_censor = lambda_censor,
99	!	time_step = time_step,
100	!	time_max = time_max
101		)
102		}
103
104	!	SimJointDataResults(
105	!	subject = subject_data,
106	!	surv_formula = object@data@survival@formula,
107	!	longitudinal = long_models,
108	!	survival = surv_models
109		)
110		}
111
112
113		add_jitter <- function(times, jitter_var = c(0, 0)) {
114	!	stopifnot(all(jitter_var >= 0))
115	!	if (jitter_var[1] > 0) {
116	!	neg_times <- times < 0
117	!	times[neg_times] <- pmin(
118	!	times[neg_times] + rnorm(sum(neg_times), sd = sqrt(jitter_var[1])),
119	!	-.Machine$double.eps / 2
120		)
121		}
122	!	if (jitter_var[2] > 0) {
123	!	pos_times <- times > 0
124	!	times[pos_times] <- pmax(
125	!	times[pos_times] + rnorm(sum(pos_times), sd = sqrt(jitter_var[2])),
126	!	.Machine$double.eps / 2
127		)
128		}
129	!	times
130		}
131
132
133		# Longitudinal Sim Object constructors --------
134		#' @noRd
135		createLongitudinalSimObject <- function(object, draw, ...) {
136	!	UseMethod("createLongitudinalSimObject")
137		}
138
139		#' Get draws value by name
140		#' @param draws matrix
141		#' @param name character to match column names of `draws` with [startsWith]
142		#' @return A vector of matching values or `NULL` if no match.
143		#' @noRd
144		get_vars <- function(draws, name) {
145	!	result <- as.numeric(draws[, startsWith(colnames(draws), name)])
146	!	if (length(result) == 0) {
147	!	NULL
148		} else {
149	!	result
150		}
151		}
152
153		#' @exportS3Method
154		createLongitudinalSimObject.LongitudinalRandomSlope <- function(
155		object,
156		draw,
157		...
158		) {
159	!	args <- list(...)
160
161	!	args$intercept <- get_vars(draw, "lm_rs_intercept")
162	!	args$slope_mu <- get_vars(draw, "lm_rs_slope_mu")
163	!	args$slope_sigma <- get_vars(draw, "lm_rs_slope_sigma")
164	!	args$sigma <- get_vars(draw, "lm_rs_sigma")
165	!	args$link_dsld <- get_vars(draw, "link_dsld")
166	!	args$link_identity <- get_vars(draw, "link_identity")
167	!	args$scaled_variance <- NULL # not defined for random slope
168	!	do.call(SimLongitudinalRandomSlope, args)
169		}
170
171		#' @exportS3Method
172		createLongitudinalSimObject.LongitudinalSteinFojo <- function(
173		object,
174		draw,
175		...
176		) {
177	!	args <- list(...)
178	!	args$sigma <- get_vars(draw, "lm_sf_sigma")
179	!	args$mu_s <- get_vars(draw, "lm_sf_mu_ks")
180	!	args$mu_g <- get_vars(draw, "lm_sf_mu_kg")
181	!	args$mu_b <- get_vars(draw, "lm_sf_mu_bsld")
182	!	args$omega_s <- get_vars(draw, "lm_sf_omega_ks")
183	!	args$omega_g <- get_vars(draw, "lm_sf_omega_kg")
184	!	args$omega_b <- get_vars(draw, "lm_sf_omega_bsld")
185	!	args$link_dsld <- get_vars(draw, "link_dsld")
186	!	args$link_ttg <- get_vars(draw, "link_ttg")
187	!	args$link_identity <- get_vars(draw, "link_identity")
188	!	args$link_growth <- get_vars(draw, "link_growth")
189	!	args$link_shrinkage <- get_vars(draw, "link_shrinkage")
190	!	do.call(SimLongitudinalSteinFojo, args)
191		}
192
193		#' @exportS3Method
194		createLongitudinalSimObject.LongitudinalGSF <- function(object, draw, ...) {
195	!	args <- list(...)
196	!	args$sigma <- get_vars(draw, "lm_gsf_sigma")
197	!	args$mu_s <- get_vars(draw, "lm_gsf_mu_ks")
198	!	args$mu_g <- get_vars(draw, "lm_gsf_mu_kg")
199	!	args$mu_b <- get_vars(draw, "lm_gsf_mu_bsld")
200	!	args$mu_phi <- get_vars(draw, "lm_gsf_mu_phi")
201	!	args$omega_s <- get_vars(draw, "lm_gsf_omega_ks")
202	!	args$omega_g <- get_vars(draw, "lm_gsf_omega_kg")
203	!	args$omega_b <- get_vars(draw, "lm_gsf_omega_bsld")
204	!	args$omega_phi <- get_vars(draw, "lm_gsf_omega_phi")
205	!	args$link_dsld <- get_vars(draw, "link_dsld")
206	!	args$link_ttg <- get_vars(draw, "link_ttg")
207	!	args$link_identity <- get_vars(draw, "link_identity")
208	!	args$link_growth <- get_vars(draw, "link_growth")
209	!	args$link_shrinkage <- get_vars(draw, "link_shrinkage")
210
211	!	do.call(SimLongitudinalGSF, args)
212		}
213
214		#' @exportS3Method
215		createLongitudinalSimObject.LongitudinalClaretBruno <- function(
216		object,
217		draw,
218		...
219		) {
220	!	args <- list(...)
221	!	args$sigma <- get_vars(draw, "lm_clbr_sigma")
222	!	args$mu_b <- get_vars(draw, "lm_clbr_mu_b")
223	!	args$mu_g <- get_vars(draw, "lm_clbr_mu_g")
224	!	args$mu_c <- get_vars(draw, "lm_clbr_mu_c")
225	!	args$mu_p <- get_vars(draw, "lm_clbr_mu_p")
226	!	args$omega_b <- get_vars(draw, "lm_clbr_omega_b")
227	!	args$omega_g <- get_vars(draw, "lm_clbr_omega_g")
228	!	args$omega_c <- get_vars(draw, "lm_clbr_omega_c")
229	!	args$omega_p <- get_vars(draw, "lm_clbr_omega_p")
230	!	args$link_dsld <- get_vars(draw, "link_dsld")
231	!	args$link_ttg <- get_vars(draw, "link_ttg")
232	!	args$link_identity <- get_vars(draw, "link_identity")
233	!	args$link_growth <- get_vars(draw, "link_growth")
234	!	args$link_shrinkage <- get_vars(draw, "link_shrinkage")
235	!	do.call(SimLongitudinalClaretBruno, args)
236		}
237
238
239		# Survival Sim Object constructors --------
240
241		#' @noRd
242		createSurvivalSimObject <- function(object, draw, ...) {
243	!	UseMethod("createSurvivalSimObject")
244		}
245
246		#' @exportS3Method
247		createSurvivalSimObject.SurvivalWeibullPH <- function(object, draw, ...) {
248	!	args <- list(...)
249	!	args$lambda <- get_vars(draw, "sm_weibull_ph_lambda")
250	!	args$gamma <- get_vars(draw, "sm_weibull_ph_gamma")
251
252	!	result <- do.call(SimSurvivalWeibullPH, args)
253	!	result@beta_os_cov <- get_vars(draw, "beta_os_cov")
254	!	result
255		}
256
257		#' @exportS3Method
258		createSurvivalSimObject.SurvivalExponential <- function(object, draw, ...) {
259	!	args <- list(...)
260	!	args$lambda <- get_vars(draw, "sm_exp_lambda")
261
262	!	result <- do.call(SimSurvivalExponential, args)
263	!	result@beta_os_cov <- get_vars(draw, "beta_os_cov")
264	!	result
265		}
266
267		#' @exportS3Method
268		createSurvivalSimObject.SurvivalGamma <- function(object, draw, ...) {
269	!	lapply(object@model@survival@parameters@parameters, function(x) x@name)
270	!	lapply(object@model@link@components, function(x) x@key)
271	!	args <- list(...)
272	!	args$k <- get_vars(draw, "sm_gamma_k")
273	!	args$theta <- get_vars(draw, "sm_gamma_theta")
274
275	!	result <- do.call(SimSurvivalGamma, args)
276	!	result@beta_os_cov <- get_vars(draw, "beta_os_cov")
277	!	result
278		}
279
280		#' @exportS3Method
281		createSurvivalSimObject.SurvivalLogLogistic <- function(object, draw, ...) {
282	!	lapply(object@model@survival@parameters@parameters, function(x) x@name)
283	!	lapply(object@model@link@components, function(x) x@key)
284	!	args <- list(...)
285	!	args$a <- get_vars(draw, "sm_loglogis_a")
286	!	args$b <- get_vars(draw, "sm_loglogis_b")
287
288	!	result <- do.call(SimSurvivalLogLogistic, args)
289	!	result@beta_os_cov <- get_vars(draw, "beta_os_cov")
290	!	result
291		}
292
293
294		sampleSubjectsFromObs <- function(object, subjects_df, covs_matrix) {
295	!	subjects_df$log_haz_cov <- rowSums(
296	!	covs_matrix[, -1] * t(sapply(object, function(x) x@beta_os_cov))
297		)
298	!	subjects_df \|>
299	!	dplyr::mutate(survival = stats::runif(dplyr::n())) \|>
300	!	dplyr::mutate(chazard_limit = -log(.data$survival)) \|>
301	!	dplyr::mutate(
302	!	time_cen = stats::rexp(
303	!	dplyr::n(),
304	!	sapply(object, function(x) x@lambda_censor)
305		)
306		)
307		}
308
309		# Simulate patient function ------
310		SimJointDataResults <- function(
311		subject,
312		surv_formula,
313		longitudinal,
314		survival,
315		.silent = FALSE
316		) {
317		# take hazard windows from first element. All have the same
318		# @time_step and @time_max parameters
319	!	hazard_evaluation_info <- hazardWindows(survival[[1]])
320
321	!	group_counts <- as.data.frame(table(subject@data[, c(
322	!	subject@study,
323	!	subject@arm
324		)]))
325
326	!	n_group <- group_counts$Freq
327	!	arms <- group_counts[, 2]
328	!	studies <- group_counts[, 1]
329	!	n_subjects <- sum(n_group)
330	!	n_times <- length(hazard_evaluation_info$midpoint)
331
332	!	baseline <- data.frame(
333	!	subject = subject@data[[subject@subject]],
334	!	study = subject@data[[subject@study]],
335	!	arm = subject@data[[subject@arm]]
336		)
337
338	!	cov_cols <- cbind(
339	!	subject = subject@data[[subject@subject]],
340	!	subject@data[, all.vars(delete.response(terms(surv_formula)))]
341		)
342
343	!	os_baseline <- sampleSubjectsFromObs(
344	!	survival,
345	!	subjects_df = baseline,
346	!	model.matrix(delete.response(terms(surv_formula)), subject@data)
347		)
348
349	!	lm_baseline <- dplyr::bind_rows(
350	!	lapply(seq.int(longitudinal), function(i) {
351	!	sampleSubjects(longitudinal[[i]], subjects_df = baseline[i, ])
352		})
353		)
354
355	!	lm_times <- lapply(seq.int(longitudinal), function(i) {
356	!	longitudinal[[i]]@times
357		})
358
359	!	lm_dat_no_obvs <-
360	!	cbind(
361	!	baseline[rep(seq.int(nrow(baseline)), times = lengths(lm_times)), ],
362	!	time = unlist(lm_times)
363		) \|>
364	!	dplyr::left_join(lm_baseline, by = c("subject", "study", "arm"))
365
366	!	lm_dat <- dplyr::bind_rows(
367	!	.mapply(
368	!	sampleObservations,
369	!	dots = list(
370	!	times_df = split(lm_dat_no_obvs, ~subject),
371	!	object = longitudinal
372		),
373	!	MoreArgs = NULL
374		)
375		)
376
377	!	hazard_eval_df <- dplyr::tibble(
378	!	subject = rep(lm_baseline$subject, each = n_times),
379	!	arm = rep(lm_baseline$arm, each = n_times),
380	!	study = rep(lm_baseline$study, each = n_times),
381	!	midpoint = rep(
382	!	as.double(hazard_evaluation_info$midpoint),
383	!	times = n_subjects
384		),
385	!	time = rep(as.double(hazard_evaluation_info$upper), times = n_subjects),
386	!	width = rep(as.double(hazard_evaluation_info$width), times = n_subjects)
387		)
388
389	!	lm_link_dat <- dplyr::bind_rows(
390	!	.mapply(
391	!	sampleObservations,
392	!	dots = list(
393	!	times_df = split(
394	!	dplyr::left_join(
395	!	hazard_eval_df,
396	!	lm_baseline,
397	!	by = c("subject", "study", "arm")
398		),
399	!	~subject
400		),
401	!	object = longitudinal
402		),
403	!	MoreArgs = NULL
404		)
405	!	)[, c(
406	!	"subject",
407	!	"study",
408	!	"arm",
409	!	"log_haz_link",
410	!	"time",
411	!	"width",
412	!	"midpoint"
413		)]
414
415	!	os_eval_df <- lm_link_dat \|>
416	!	dplyr::left_join(os_baseline, by = c("subject", "study", "arm"))
417
418	!	times_df <- split(os_eval_df, ~subject)
419	!	os_data_list <- list()
420	!	for (i in seq_along(times_df)) {
421	!	times_df[[i]]$log_bl_haz <- survival[[i]]@loghazard(
422	!	times_df[[i]]$midpoint
423		)
424		}
425	!	os_dat <- sampleObservations2(dplyr::bind_rows(times_df))
426
427	!	os_dat <- dplyr::left_join(os_dat, cov_cols, by = "subject")
428
429	!	lm_dat2 <- lm_dat \|>
430	!	dplyr::left_join(
431	!	dplyr::select(os_dat, "subject", os_time = "time"),
432	!	by = "subject"
433		) \|>
434	!	dplyr::mutate(observed = (.data$time <= .data$os_time)) \|>
435	!	dplyr::arrange(dplyr::pick(c("subject", "time")))
436
437	!	assert_that(
438	!	length(unique(os_dat$subject)) == length(os_dat$subject),
439	!	length(os_dat$subject) == n_subjects,
440	!	all(os_dat$time >= 0),
441	!	all(os_dat$event %in% c(0, 1)),
442	!	msg = "Assumptions for the Survival data are not met (please report this issue)"
443		)
444
445	!	assert_that(
446	!	nrow(lm_dat2) == n_subjects * length(longitudinal[[1]]@times),
447	!	length(unique(lm_dat2$subject)) == n_subjects,
448	!	msg = "Assumptions for the Longitudinal data are not met (please report this issue)"
449		)
450
451	!	original_names <- c("subject", "arm", "study")
452	!	names(original_names) <- c(subject@subject, subject@arm, subject@study)
453
454	!	return(
455	!	.SimJointData(
456	!	survival = os_dat \|> dplyr::rename(dplyr::all_of(original_names)),
457	!	longitudinal = lm_dat2[, c(
458	!	"subject",
459	!	"arm",
460	!	"study",
461	!	"time",
462	!	"sld",
463	!	"observed"
464		)] \|>
465	!	dplyr::rename(dplyr::all_of(original_names))
466		)
467		)
468		}
469
470
471		# adapted from sampleObservations so that $midpoint and $log_bl_haz are already in times_df.
472		sampleObservations2 <- function(times_df) {
473	!	assert_that(
474	!	all(times_df$time >= 0),
475	!	msg = "All time points must be greater than or equal to 0"
476		)
477
478	!	os_dat_chaz <- times_df \|>
479		# Fix to avoid issue with log(0) = NaN values
480	!	dplyr::mutate(
481	!	log_bl_haz = dplyr::if_else(
482	!	.data$midpoint == 0,
483	!	-999,
484	!	.data$log_bl_haz
485		),
486	!	hazard_instant = exp(
487	!	.data$log_bl_haz + .data$log_haz_cov + .data$log_haz_link
488		),
489		# Reset Inf values to large number to avoid NaN issues downstream
490		# This is suitable as Hazard limits tend to be in the range of -10 to 10 so large numbers
491		# are essentially equivalent to infinity for simulation purposes
492	!	hazard_instant = dplyr::if_else(
493	!	.data$hazard_instant == Inf,
494	!	999,
495	!	.data$hazard_instant
496		),
497	!	hazard_instant = dplyr::if_else(
498	!	.data$hazard_instant == -Inf,
499	!	-999,
500	!	.data$hazard_instant
501		),
502	!	hazard_interval = .data$hazard_instant * .data$width
503		) \|>
504	!	dplyr::mutate(chazard = cumsum(.data$hazard_interval), .by = "subject")
505
506	!	os_had_event <- os_dat_chaz \|>
507	!	dplyr::filter(.data$chazard >= .data$chazard_limit) \|>
508	!	dplyr::slice_head(by = "subject") \|>
509	!	dplyr::mutate(event = 1)
510
511	!	os_had_censor <- os_dat_chaz \|>
512	!	dplyr::filter(!.data$subject %in% os_had_event$subject) \|>
513	!	dplyr::slice_tail(by = "subject") \|>
514
515	!	dplyr::mutate(event = 0)
516
517	!	if (!(nrow(os_had_censor) == 0)) {
518	!	message(sprintf(
519	!	"INFO: %i subject(s) did not die before max(times)",
520	!	nrow(os_had_censor)
521		))
522		}
523
524	!	os_dat_complete <- os_had_event \|>
525	!	dplyr::bind_rows(os_had_censor) \|>
526	!	dplyr::mutate(
527	!	real_time = .data$time,
528	!	event = dplyr::if_else(
529	!	.data$real_time <= .data$time_cen,
530	!	.data$event,
531	!	0
532		),
533	!	time = dplyr::if_else(
534	!	.data$real_time <= .data$time_cen,
535	!	.data$real_time,
536	!	.data$time_cen
537		)
538		) \|>
539	!	dplyr::arrange(.data$subject)
540
541	!	keep_cols <- colnames(os_dat_complete) %in%
542	!	c("subject", "study", "arm", "time", "event", "cov_cont", "cov_cat")
543	!	os_dat_complete[, keep_cols]
544		}

1		#' @include JointModel.R
2		#' @include SurvivalQuantities.R
3		NULL
4
5		setOldClass("CmdStanMCMC")
6
7		# JointModelSamples-class ----
8
9		#' `JointModelSamples`
10		#'
11		#' Contains samples from a [`JointModel`].
12		#'
13		#' @slot model ([`JointModel`])\cr the model that the samples were drawn from.
14		#' @slot data ([`DataJoint`])\cr the data that the model was fitted on.
15		#' @slot results ([`cmdstanr::CmdStanMCMC`])\cr the STAN samples.
16		#'
17		#' @aliases JointModelSamples
18		#' @export
19		.JointModelSamples <- setClass(
20		"JointModelSamples",
21		slots = c(
22		model = "JointModel",
23		data = "DataJoint",
24		results = "CmdStanMCMC"
25		)
26		)
27
28
29		#' @rdname generateQuantities
30		#' @typed generator: QuantityGenerator
31		#' object that specifies which subjects and time points
32		#' to calculate the quantities at
33		#' @typed type: character
34		#' type of quantities to be generated, must be either "survival" or
35		#' "longitudinal".
36		#' @export
37		generateQuantities.JointModelSamples <- function(object, generator, type, ...) {
38	37x	data <- as_stan_list(object@data) \|>
39	37x	append(as_stan_list(object@model@parameters)) \|>
40	37x	append(as_stan_list(
41	37x	generator,
42	37x	data = object@data,
43	37x	model = object@model
44		))
45
46	36x	stanobj <- as.StanModule(object, generator = generator, type = type)
47	36x	model <- compileStanModel(stanobj)
48
49	36x	devnull <- utils::capture.output(
50	36x	results <- model$generate_quantities(
51	36x	data = data,
52	36x	fitted_params = object@results
53		)
54		)
55	36x	return(results)
56		}
57
58
59		#' `JointModelSamples` -> `StanModule`
60		#'
61		#' Converts a `JointModelSamples` object into a `StanModule` object ensuring
62		#' that the resulting `StanModule` object is able to generate post sampling
63		#' quantities.
64		#'
65		#' @inheritParams generateQuantities
66		#' @export
67		as.StanModule.JointModelSamples <- function(object, generator, type, ...) {
68	44x	assert_that(
69	44x	is(generator, "QuantityGenerator"),
70	44x	length(type) == 1,
71	44x	type %in% c("survival", "longitudinal")
72		)
73
74	44x	quant_stanobj <- read_stan("base/quantities.stan") \|>
75	44x	decorated_render(
76	44x	include_gq_longitudinal_idv = (type == "longitudinal") &
77	44x	is(generator, "QuantityGeneratorSubject"),
78	44x	include_gq_longitudinal_pop = (type == "longitudinal") &
79	44x	is(generator, "QuantityGeneratorPopulation"),
80	44x	include_gq_survival_idv = (type == "survival") &
81	44x	is(generator, "QuantityGeneratorSubject"),
82	44x	include_gq_survival_pred = (type == "survival") &
83	44x	is(generator, "QuantityGeneratorPrediction")
84		) \|>
85	44x	StanModule()
86
87	44x	stanobj <- Reduce(
88	44x	merge,
89	44x	list(
90	44x	as.StanModule(object@model),
91	44x	enableGQ(object@model),
92	44x	quant_stanobj
93		)
94		)
95	44x	stanobj
96		}
97
98
99		#' `JointModelSamples` -> Printable `Character`
100		#'
101		#' Converts [`JointModelSamples`] object into a printable string.
102		#'
103		#' @typed object: JointModelSamples
104		#' samples as drawn from a [`JointModel`].
105		#' @family JointModelSamples
106		#' @typed indent: numeric
107		#' how much white space to prefix the print string with.
108		#' @keywords internal
109		#' @export
110		as_print_string.JointModelSamples <- function(object, indent = 1, ...) {
111	17x	sizes <- vapply(
112	17x	cmdstanr::as.CmdStanMCMC(object)$metadata()[["stan_variable_sizes"]],
113	17x	\(x) {
114	265x	if (length(x) == 1 && x == 1) {
115	82x	return("")
116		}
117	183x	paste0("[", paste(x, collapse = ", "), "]")
118		},
119	17x	character(1)
120		)
121	17x	variable_string <- paste0(
122		" ",
123	17x	cmdstanr::as.CmdStanMCMC(object)$metadata()[["stan_variables"]],
124	17x	sizes
125		)
126	17x	template <- c(
127	17x	"JointModelSamples Object with:",
128		"",
129	17x	" # of samples per chain = %d",
130	17x	" # of chains = %d",
131		"",
132	17x	" Variables:",
133	17x	variable_string[order(variable_string)]
134		)
135	17x	pad <- rep(" ", indent) \|> paste(collapse = "")
136	17x	template_padded <- paste(pad, template)
137	17x	sprintf(
138	17x	paste(template_padded, collapse = "\n"),
139	17x	cmdstanr::as.CmdStanMCMC(object)$metadata()$iter_sampling,
140	17x	cmdstanr::as.CmdStanMCMC(object)$num_chains()
141		)
142		}
143
144		#' @rdname show-object
145		#' @export
146		setMethod(
147		f = "show",
148		signature = "JointModelSamples",
149		definition = function(object) {
150	17x	string <- as_print_string(object)
151	17x	cat("\n", string, "\n\n")
152		}
153		)
154
155
156		#' @rdname as.CmdStanMCMC
157		as.CmdStanMCMC.JointModelSamples <- function(object, ...) {
158	78x	return(object@results)
159		}
160
161
162		#' Save a `JointModelSamples` object to a file.
163		#'
164		#' This function is just a wrapper around `saveRDS` that saves the object to a file
165		#' ensuring that all of the Stan samples are correctly stored. Note that as
166		#' `cmdstanr` objects store their samples as a csv file the samples may be lost
167		#' if you call `saveRDS` directly on the object.
168		#'
169		#' @typed object: JointModelSamples
170		#' the object to save.
171		#' @typed file: character
172		#' the file to save the object to.
173		#' @typed ...: ANY
174		#' additional arguments to [`saveRDS`].
175		#'
176		#' @family saveObject
177		#'
178		#' @export
179		saveObject.JointModelSamples <- function(object, file, ...) {
180	1x	object@results$draws()
181	1x	try(object@results$sampler_diagnostics(), silent = TRUE)
182	1x	try(object@results$init(), silent = TRUE)
183	1x	try(object@results$profiles(), silent = TRUE)
184	1x	saveRDS(object, file, ...)
185		}

1		#' Re-used documentation for `DataSubject`
2		#'
3		#' @typed object: DataSubject
4		#' subject-level data.
5		#' @typed x: DataSubject
6		#' subject-level data.
7		#' @param ... Not Used.
8		#'
9		#' @name DataSubject-Shared
10		#' @keywords internal
11		NULL
12
13
14		#' Subject Data Object and Constructor Function
15		#'
16		#' The [`DataSubject`] class handles the processing of the subject data for
17		#' fitting a [`JointModel`].
18		#'
19		#' @slot data (`data.frame`)\cr the subject-level data.
20		#' @slot subject (`character`)\cr the name of the variable containing the subject identifier.
21		#' @slot arm (`character`)\cr the name of the variable containing the arm identifier.
22		#' @slot study (`character`)\cr the name of the variable containing the study identifier.
23		#'
24		#' @family DataObjects
25		#' @family DataSubject
26		#' @exportClass DataSubject
27		#' @export DataSubject
28		.DataSubject <- setClass(
29		Class = "DataSubject",
30		representation = list(
31		data = "data.frame",
32		subject = "character",
33		arm = "character",
34		study = "character"
35		)
36		)
37
38
39		#' @typed data: data.frame
40		#' the subject-level data.
41		#' @typed subject: character
42		#' the name of the variable containing the subject identifier.
43		#' @typed arm: character
44		#' the name of the variable containing the arm identifier.
45		#' @typed study: character
46		#' the name of the variable containing the study identifier.
47		#' @rdname DataSubject-class
48		#' @export
49		DataSubject <- function(data, subject, arm, study) {
50	403x	vars <- c(subject, arm, study)
51	403x	vars_frm_chr <- paste0("~ ", paste(vars, collapse = " + "))
52	403x	.DataSubject(
53	403x	data = remove_missing_rows(data, stats::as.formula(vars_frm_chr)),
54	403x	subject = subject,
55	403x	arm = arm,
56	403x	study = study
57		)
58		}
59
60		setValidity(
61		"DataSubject",
62		method = function(object) {
63		if (length(object@subject) != 1) {
64		return("`subject` must be a length 1 character")
65		}
66		if (length(object@arm) != 1) {
67		return("`arm` must be a length 1 character")
68		}
69		if (length(object@study) != 1) {
70		return("`study` must be a length 1 character")
71		}
72		if (nrow(object@data) == 0) {
73		return("`data` should not have 0 rows")
74		}
75		sbj <- object@data[[object@subject]]
76		if (!(is(sbj, "character") \| is(sbj, "factor"))) {
77		return("`data[[subject]]` should be of type character or factor")
78		}
79		}
80		)
81
82
83		#' @inheritParams DataSubject-Shared
84		#' @inherit extractVariableNames description title
85		#'
86		#' @returns
87		#' A list with the following named elements:
88		#' - `subject` (`character`)\cr the name of the variable containing the subject identifier.
89		#' - `arm` (`character`)\cr the name of the variable containing the arm identifier.
90		#' - `study` (`character`) \cr the name of the variable containing the study identifier.
91		#' @family DataSubject
92		#' @family extractVariableNames
93		#' @export
94		#' @keywords internal
95		extractVariableNames.DataSubject <- function(object) {
96	1103x	list(
97	1103x	subject = object@subject,
98	1103x	arm = object@arm,
99	1103x	study = object@study
100		)
101		}
102
103
104		#' @rdname as_stan_list.DataObject
105		#' @family DataSubject
106		#' @export
107		as_stan_list.DataSubject <- function(object, ...) {
108	334x	df <- as.data.frame(harmonise(object))
109	334x	vars <- extractVariableNames(object)
110
111	334x	unique_arm_study_combos <- unique(
112	334x	data.frame(
113	334x	arm = as.numeric(df[[vars$arm]]),
114	334x	study = as.numeric(df[[vars$study]])
115		)
116		)
117
118	334x	list(
119	334x	n_subjects = nrow(df),
120	334x	n_studies = length(unique(df[[vars$study]])),
121	334x	n_arms = length(unique(df[[vars$arm]])),
122	334x	subject_study_index = as.numeric(df[[vars$study]]),
123	334x	subject_arm_index = as.numeric(df[[vars$arm]]),
124	334x	subject_to_index = stats::setNames(
125	334x	seq_len(nlevels(df[[vars$subject]])),
126	334x	levels(df[[vars$subject]])
127		),
128	334x	arm_to_index = stats::setNames(
129	334x	seq_len(nlevels(df[[vars$arm]])),
130	334x	levels(df[[vars$arm]])
131		),
132	334x	study_to_index = stats::setNames(
133	334x	seq_len(nlevels(df[[vars$study]])),
134	334x	levels(df[[vars$study]])
135		),
136	334x	pop_arm_index = unique_arm_study_combos$arm,
137	334x	pop_study_index = unique_arm_study_combos$study
138		)
139		}
140
141		#' @rdname as_stan_list.DataObject
142		#' @export
143		as.list.DataSubject <- function(x, ...) {
144	!	as_stan_list(x, ...)
145		}
146
147
148		#' `DataSubject` -> `data.frame`
149		#'
150		#' @inheritParams DataSubject-Shared
151		#'
152		#' @description
153		#' Converts a [`DataSubject`] object into a `data.frame`.
154		#' The subject variable is cast to factor.
155		#' @family DataSubject
156		#' @export
157		as.data.frame.DataSubject <- function(x, ...) {
158	793x	x <- x@data
159	793x	rownames(x) <- NULL
160	793x	x
161		}
162
163
164		#' @rdname harmonise
165		#' @exportS3Method NULL
166		harmonise.DataSubject <- function(object, ...) {
167	368x	data <- as.data.frame(object)
168	368x	vars <- extractVariableNames(object)
169	368x	assert_that(
170	368x	vars$subject %in% names(data),
171	368x	vars$arm %in% names(data),
172	368x	vars$study %in% names(data)
173		)
174	368x	assert_character(
175	368x	as.character(data[[vars$subject]]),
176	368x	any.missing = FALSE,
177	368x	unique = TRUE
178		)
179	367x	data[[vars$subject]] <- factor(data[[vars$subject]])
180	367x	data[[vars$arm]] <- factor(data[[vars$arm]])
181	367x	data[[vars$study]] <- factor(data[[vars$study]])
182	367x	data <- data[order(data[[vars$subject]]), ]
183	367x	DataSubject(
184	367x	data = data,
185	367x	subject = object@subject,
186	367x	arm = object@arm,
187	367x	study = object@study
188		)
189		}
190
191		#' `DataSubject` -> Printable `Character`
192		#'
193		#' Converts [`DataSubject`] object into a printable string.
194		#' @inheritParams DataSubject-Shared
195		#' @family DataSubject
196		#' @keywords internal
197		#' @typed indent: numeric
198		#' how much white space to prefix the print string with.
199		#' @export
200		as_print_string.DataSubject <- function(object, indent = 1, ...) {
201	4x	template <- c(
202	4x	"Subject-Data Object:",
203	4x	" # of Subjects = %d",
204	4x	" # of Studies = %d",
205	4x	" # of Arms = %d"
206		)
207	4x	pad <- rep(" ", indent) \|> paste(collapse = "")
208	4x	template_padded <- paste(pad, template)
209	4x	vars <- extractVariableNames(object)
210	4x	sprintf(
211	4x	paste(template_padded, collapse = "\n"),
212	4x	nrow(object@data),
213	4x	length(unique(object@data[[vars$study]])),
214	4x	length(unique(object@data[[vars$arm]]))
215		)
216		}
217
218		#' @rdname show-object
219		#' @export
220		setMethod(
221		f = "show",
222		signature = "DataSubject",
223		definition = function(object) {
224	1x	string <- as_print_string(object)
225	1x	cat("\n", string, "\n\n")
226		}
227		)

1		#' @include StanModel.R
2		NULL
3
4		# SurvivalModel-class ----
5
6		#' `SurvivalModel`
7		#'
8		#' This class extends the general [`StanModel`] class to comprise the survival
9		#' model specification.
10		#'
11		#' @exportClass SurvivalModel
12		.SurvivalModel <- setClass(
13		Class = "SurvivalModel",
14		contains = "StanModel"
15		)
16
17		# SurvivalModel-constructors ----
18
19		#' @rdname SurvivalModel-class
20		#'
21		#' @inheritParams stanmodel_arguments
22		#'
23		#' @export
24		SurvivalModel <- function(
25		stan = StanModule(),
26		parameters = ParameterList(),
27		name = "<Unnamed>",
28		...
29		) {
30	50x	base_stan <- read_stan("base/survival.stan")
31	50x	stan_full <- decorated_render(
32	50x	.x = base_stan,
33	50x	stan = add_missing_stan_blocks(as.list(stan))
34		)
35	50x	.SurvivalModel(
36	50x	StanModel(
37	50x	name = name,
38	50x	stan = StanModule(stan_full),
39	50x	parameters = parameters,
40		...
41		)
42		)
43		}
44
45		#' @export
46		as_print_string.SurvivalModel <- function(object, ...) {
47	12x	string <- sprintf(
48	12x	"\n%s Survival Model with parameters:\n%s\n\n",
49	12x	object@name,
50	12x	paste(" ", as_print_string(object@parameters)) \|>
51	12x	paste(collapse = "\n")
52		)
53	12x	return(string)
54		}

1		# "missing" = no argument provided
2		# "NULL" = explicit NULL
3		setClassUnion("empty", c("missing", "NULL"))
4		setClassUnion("numeric_or_NULL", c("numeric", "NULL"))
5		setClassUnion("character_or_NULL", c("character", "NULL"))
6
7		# merge ----
8
9		#' `merge`
10		#'
11		#' Merge two `StanModule` or `ParameterList` objects.
12		#'
13		#' @param x first module.
14		#' @param y second module.
15		#' @param ... additional arguments.
16		#'
17		#' @export
18		# Needs to be S4 for multiple dispatch !
19		setGeneric(
20		name = "merge",
21		def = function(x, y, ...) standardGeneric("merge")
22		)
23
24
25		# show ----
26
27		#' Printing of Different Classes
28		#'
29		#' These methods print objects of different classes.
30		#'
31		#' @name show
32		#' @aliases show
33		#'
34		#' @param object what to print.
35		#'
36		#' @export
37		NULL
38
39
40		# write_stan ----
41
42		#' `write_stan`
43		#'
44		#' Write the Stan code for a Stan module.
45		#'
46		#' @param object the module.
47		#' @typed destination: "`character` or `connection`"
48		#' Where to write stan code to.
49		#' @param ... Additional arguments
50		#'
51		#' @export
52		write_stan <- function(object, destination, ...) {
53	!	UseMethod("write_stan")
54		}
55
56		# compileStanModel ----
57
58		#' `compileStanModel`
59		#'
60		#' Compile the Stan module.
61		#'
62		#' @param object the module.
63		#'
64		#' @export
65		compileStanModel <- function(object) {
66	71x	UseMethod("compileStanModel")
67		}
68
69
70		# sampleStanModel ----
71
72		#' `sampleStanModel`
73		#'
74		#' Sample from a Stan Module.
75		#'
76		#' @param object the module.
77		#' @param ... additional arguments.
78		#'
79		#' @export
80		sampleStanModel <- function(object, ...) {
81	17x	UseMethod("sampleStanModel")
82		}
83
84
85		# as.StanModule ----
86
87		#' `as.StanModule`
88		#'
89		#' Converts an object into a [`StanModule`].
90		#'
91		#' @param object what to convert.
92		#' @param ... additional options.
93		#' @family as.StanModule
94		#' @keywords internal
95		as.StanModule <- function(object, ...) {
96	2281x	UseMethod("as.StanModule")
97		}
98
99
100		#' `getParameters`
101		#'
102		#' Extract any modelling parameters as a [`ParameterList`] object
103		#' from a model.
104		#'
105		#' @param object where to obtain the parameters from.
106		#' @param ... additional options.
107		#'
108		#' @export
109		getParameters <- function(object, ...) {
110	211x	UseMethod("getParameters")
111		}
112
113
114		# extractVariableNames ----
115
116		#' Extract Mapping to Standardised Variable Names
117		#'
118		#' @description
119		#' Extract a `list` that maps the variable names in a user-defined
120		#' `data.frame` to standardised values.
121		#'
122		#' @param object the data object.
123		#' @family extractVariableNames
124		#' @keywords internal
125		extractVariableNames <- function(object) {
126	1893x	UseMethod("extractVariableNames")
127		}
128
129
130		# initialValues ----
131
132		#' `initialValues`
133		#'
134		#' Obtain the `list` of initial values to be passed to the Stan sampler.
135		#'
136		#' @param object where to get the initial values from.
137		#' @param n_chains the number of initial values to generate. See details.
138		#' @param ... Not currently used.
139		#'
140		#' @details
141		#' There are multiple ways of specifying initial values to Stan, see the `init` argument
142		#' in [cmdstanr::model-method-sample] for full details. Within this package we supply
143		#' initial values via a list of lists where each inner list contains the initial values
144		#' for a single chain. As such the `n_chains` argument specifies the number of inner lists
145		#' to generate.
146		#'
147		#' See the Vignette for further details of how to specify initial values.
148		#'
149		#' @export
150		initialValues <- function(object, ...) {
151	88573x	UseMethod("initialValues")
152		}
153
154
155		# size ----
156
157		#' `size`
158		#'
159		#' Obtain the `list` of parameter sizes.
160		#'
161		#' @param object where to get the parameter sizes from.
162		#'
163		#' @keywords internal
164		size <- function(object) {
165	150x	UseMethod("size")
166		}
167
168
169		# generateQuantities ----
170
171		#' `generateQuantities`
172		#'
173		#' Obtain the generated quantities from a Stan Model.
174		#'
175		#' @param object object to obtain generated quantities from
176		#' @param ... additional options.
177		#'
178		#' @export
179		generateQuantities <- function(object, ...) {
180	37x	UseMethod("generateQuantities")
181		}
182
183
184		#' Prepare Data Object
185		#'
186		#' @typed object: "`DataSubject` or `DataLongitudinal` or `DataSurvival`"
187		#' data object to "harmonise"
188		#' @typed subject_var: character
189		#' the name of the variable containing the subject identifier.
190		#' @typed subject_ord: character
191		#' the expected levels (in order) of the subject identifier.
192		#' @param ... not used.
193		#'
194		#' @details
195		#' This utility function prepares the datasets in the data objects in order to ensure they
196		#' are consistent and compatible with each other.
197		#'
198		#' In particular it ensures that the `subject` variable, as specified by `DataSubject`,
199		#' is available in `DataLongitudinal` and `DataSurvival` and that all levels are present
200		#' in all 3 data objects.
201		#'
202		#' It also sorts the datasets to ensure that indexes are consistent e.g. index 1 for
203		#' `DataSubject@data` corresponds to the same subject as index 1 for `DataSurvival@data`.
204		#' For `DataLongitudinal` the data is additionally sorted by time and outcome value.
205		#'
206		#' @seealso [`DataJoint`], [`DataSurvival`], [`DataSubject`], [`DataLongitudinal`]
207		#'
208		#' @keywords internal
209		#' @return Returns the original object but with the data standardised (see details)
210		harmonise <- function(object, ...) {
211	431x	UseMethod("harmonise")
212		}
213
214
215		#' @rdname harmonise
216		harmonise.default <- function(object, ...) {
217	14x	NULL
218		}
219
220
221		#' `as_stan_list`
222		#'
223		#' @description
224		#' Extracts a list of data elements from an object to be used as input
225		#' to a Stan Model
226		#'
227		#' @param object to be converted.
228		#' @param ... additional options.
229		#'
230		#' @family as_stan_list
231		#' @export
232		as_stan_list <- function(object, ...) {
233	2301x	UseMethod("as_stan_list")
234		}
235
236		#' @rdname as_stan_list
237		#' @export
238		as_stan_list.default <- function(object, ...) {
239	32x	NULL
240		}
241
242
243		#' `as_print_string`
244		#'
245		#' @description
246		#' Returns the character representation of an object which is suitable
247		#' for printing to the console
248		#'
249		#' @param object to be converted to string.
250		#' @param ... additional options.
251		#'
252		#' @family as_print_string
253		#' @keywords internal
254		as_print_string <- function(object, ...) {
255	128x	UseMethod("as_print_string")
256		}
257
258		#' Show an Object
259		#'
260		#' Prints an object to the console.
261		#'
262		#' @param object Object to be printed
263		#'
264		#' @name show-object
265		NULL
266
267
268		#' `brierScore`
269		#'
270		#' @description
271		#' Returns the Brier Score for a given model
272		#'
273		#' @param object to calculate Brier Score for.
274		#' @param ... additional options.
275		#'
276		#' @family brierScore
277		#' @export
278		brierScore <- function(object, ...) {
279	3x	UseMethod("brierScore")
280		}
281
282
283		#' Generate Simulated Observations
284		#'
285		#' @typed object: "`SimLongitudinal` or `SimSurvival`"
286		#' object to generate observations from.
287		#' @typed times_df: data.frame
288		#' the times at which to generate observations. See details.
289		#'
290		#' @details
291		#' The `times_df` argument should be a `data.frame` as created by `sampleSubjects` but
292		#' replicated for each time point at which observations are to be generated. That is if you want
293		#' to generate observations for times `c(0, 1, 2, 3)` then `times_df` should be created as:
294		#' ```
295		#' subject_dat <- sampleSubjects(object, ...)
296		#' times_df <- tidyr::expand_grid(
297		#' subject_dat,
298		#' time = c(0, 1, 2, 3)
299		#' )
300		#' ```
301		#'
302		#' @export
303		sampleObservations <- function(object, times_df) {
304	76x	UseMethod("sampleObservations")
305		}
306
307
308		#' Generate Simulated Subjects
309		#'
310		#' @typed object: "`SimLongitudinal` or `SimSurvival`"
311		#' object to generate subjects from.
312		#' @typed subjects_df: data.frame
313		#' the subjects to generate observations for. See details.
314		#'
315		#' @details
316		#' The `subjects_df` argument should be a `data.frame` with 1 row per desired subject to create
317		#' with the following columns:
318		#' - `study` (`factor`) the study identifier.
319		#' - `arm` (`factor`) the treatment arm identifier.
320		#' - `subject` (`character`) the subject identifier.
321		#'
322		#' This method takes care of generating all the individual subject data required for the
323		#' [`sampleObservations`] method to generate the observations.
324		#' @export
325		sampleSubjects <- function(object, subjects_df) {
326	52x	UseMethod("sampleSubjects")
327		}
328
329
330		#' Generate time windows for evaluating a hazard function
331		#'
332		#' @typed object: SurvivalModel
333		#' object to generate time windows for.
334		#' @param ... Not used.
335		#'
336		hazardWindows <- function(object, ...) {
337	24x	UseMethod("hazardWindows")
338		}
339
340		#' @rdname Quant-Dev
341		#' @export
342		as.QuantityGenerator <- function(object, ...) {
343	112x	UseMethod("as.QuantityGenerator")
344		}
345
346		#' @rdname Quant-Dev
347		#' @export
348		as.QuantityCollapser <- function(object, ...) {
349	43x	UseMethod("as.QuantityCollapser")
350		}
351
352
353		#' Coalesce Time
354		#'
355		#' @typed object: Grid
356		#' object to coalesce time for.
357		#' @typed times: numeric
358		#' the times to coalesce to.
359		#' @param ... Not used
360		#'
361		#' Method used to replace NULL times on grid objects (if appropriate)
362		#'
363		#' @keywords internal
364		coalesceGridTime <- function(object, times, ...) {
365	43x	UseMethod("coalesceGridTime")
366		}
367		#' @export
368		coalesceGridTime.default <- function(object, times, ...) {
369	5x	object
370		}
371
372
373		#' Resolve a Promise
374		#'
375		#' @typed object: ANY
376		#' an object to resolve.
377		#' @typed ...: ANY
378		#' additional arguments.
379		#'
380		#' If `object` is not a promise will just return itself else will resolve the promise
381		#' and return the promised object.
382		#'
383		#' @export
384		resolvePromise <- function(object, ...) {
385	105x	UseMethod("resolvePromise")
386		}
387
388		#' @rdname resolvePromise
389		#' @export
390		resolvePromise.default <- function(object, ...) {
391	!	object
392		}
393
394		#' Enable Link Generic
395		#'
396		#' @typed object: LongitudinalModel
397		#' to enable link for.
398		#' @param ... Not used.
399		#'
400		#' Optional hook method that is called on a [`LongitudinalModel`] only if a link method
401		#' is provided to [`JointModel`]. This can be used to allow the model to include any
402		#' optional stan code that is only required if there are links present.
403		#'
404		#' @return [`LongitudinalModel`] object
405		#'
406		#' @export
407		enableLink <- function(object, ...) {
408	21x	UseMethod("enableLink")
409		}
410		#' @export
411		enableLink.default <- function(object, ...) {
412	!	object
413		}
414
415
416		#' Enable Generated Quantities Generic
417		#'
418		#' @typed object: StanModel
419		#' to enable generated quantities for.
420		#' @param ... Not used.
421		#'
422		#' Optional hook method that is called on a [`StanModel`] if attempting to use
423		#' either [`LongitudinalQuantities`] or [`SurvivalQuantities`]
424		#'
425		#' @return [`StanModule`] object
426		#'
427		#' @export
428		enableGQ <- function(object, ...) {
429	132x	UseMethod("enableGQ")
430		}
431		#' @export
432		enableGQ.default <- function(object, ...) {
433	46x	StanModule()
434		}
435
436
437		#' Get Prediction Names
438		#'
439		#' Utility function that returns the names of the required parameters for predicting
440		#' survival quantities with [`GridPrediction`].
441		#'
442		#' @typed object: LongitudinalModel
443		#' A longitudinal model object
444		#' @param ... Not used.
445		#' @export
446		getPredictionNames <- function(object, ...) {
447	6x	UseMethod("getPredictionNames")
448		}
449
450		#' @rdname getPredictionNames
451		#' @export
452		getPredictionNames.default <- function(object, ...) {
453	1x	NULL
454		}
455
456
457		#' Get Random Effects Names
458		#'
459		#' Utility function that returns the names of the random effects parameters.
460		#' The main use for this is to allow the [`LongitudinalRandomEffects`] function
461		#' to know which parameters it needs to extract and to what common names
462		#' it should map the parameters to.
463		#'
464		#' @typed object: LongitudinalModel
465		#' A longitudinal model object
466		#' @param ... Not used.
467		#' @export
468		getRandomEffectsNames <- function(object, ...) {
469	2x	UseMethod("getRandomEffectsNames")
470		}
471
472		#' @rdname getRandomEffectsNames
473		#' @export
474		getRandomEffectsNames.default <- function(object, ...) {
475	!	NULL
476		}
477
478
479		#' As Formula
480		#'
481		#' Utility wrapper function to convert an object to a formula.
482		#' @typed x: ANY
483		#' object to convert to a formula.
484		#' @param ... Not used.
485		#' @export
486		as_formula <- function(x, ...) {
487	7x	UseMethod("as_formula")
488		}
489
490		#' @importFrom stats as.formula
491		#' @export
492		as_formula.default <- function(x, ...) {
493	!	as.formula(x, ...)
494		}
495
496
497		#' Set Constraints
498		#'
499		#' Applies constraints to a prior distribution to ensure any sampled numbers
500		#' from the distribution fall within the constraints
501		#'
502		#' @typed object: Prior
503		#' a prior distribution to apply constraints to
504		#' @typed lower: numeric
505		#' lower constraint boundary
506		#' @typed upper: numeric
507		#' upper constraint boundary
508		#'
509		#' @export
510		set_limits <- function(object, lower = -Inf, upper = Inf) {
511	422x	UseMethod("set_limits")
512		}
513
514
515		#' Save Object to File
516		#'
517		#' @typed object: ANY
518		#' object to save.
519		#' @typed file: character
520		#' file to save object to.
521		#' @typed ...: ANY
522		#' additional arguments.
523		#'
524		#' @family saveObject
525		#' @export
526		saveObject <- function(object, file, ...) {
527	1x	UseMethod("saveObject")
528		}

1		#' @include generics.R
2		#' @include Parameter.R
3		#' @include Prior.R
4		NULL
5
6
7		#' ParameterList-Shared
8		#' @typed object: ParameterList
9		#' A List of [`Parameter`] Objects.
10		#' @typed x: ParameterList
11		#' A List of [`Parameter`] Objects.
12		#' @param ... Not Used.
13		#' @keywords internal
14		#' @name ParameterList-Shared
15		NULL
16
17
18		# ParameterList-class ----
19
20		#' `ParameterList`
21		#'
22		#' This class extends the general [`list`] type for containing [`Parameter`]
23		#' specifications.
24		#'
25		#'
26
27		#' @slot parameters (`list`) \cr a list of [`Parameter`] objects
28		#' @family ParameterList
29		#' @export ParameterList
30		#' @exportClass ParameterList
31		.ParameterList <- setClass(
32		Class = "ParameterList",
33		slots = c(
34		parameters = "list"
35		)
36		)
37		#' @typed ...: Parameter
38		#' which parameter specifications to include.
39		#' @rdname ParameterList-class
40		ParameterList <- function(...) {
41	332x	.ParameterList(parameters = list(...))
42		}
43
44		# ParameterList-validity ----
45
46		setValidity(
47		Class = "ParameterList",
48		method = function(object) {
49		is_parameters <- vapply(
50		object@parameters,
51		function(x) is(x, "Parameter"),
52		logical(1)
53		)
54		if (!all(is_parameters)) {
55		return("all elements must be of class 'Parameter'")
56		}
57		return(TRUE)
58		}
59		)
60
61
62		# as.StanModule-ParameterList ----
63
64		#' `ParameterList` -> `StanModule`
65		#'
66		#' Converts a [`ParameterList`] object to a [`StanModule`] object
67		#'
68		#' @inheritParams ParameterList-Shared
69		#'
70		#' @family ParameterList
71		#' @family as.StanModule
72		#' @export
73		as.StanModule.ParameterList <- function(object, ...) {
74	97x	stan_modules <- lapply(
75	97x	object@parameters,
76	97x	as.StanModule
77		)
78	97x	assert_that(
79	97x	all(vapply(stan_modules, inherits, logical(1), "StanModule"))
80		)
81	97x	Reduce(merge, stan_modules)
82		}
83
84
85		#' `ParameterList` -> `list`
86		#'
87		#' Converts a ParameterList object to a list of parameter data values
88		#' for a Stan model.
89		#'
90		#' @inheritParams ParameterList-Shared
91		#'
92		#' @family as_stan_list
93		#' @family ParameterList
94		#' @export
95		as_stan_list.ParameterList <- function(object, ...) {
96	55x	stan_lists <- lapply(
97	55x	object@parameters,
98	55x	as_stan_list
99		)
100	55x	assert_that(
101	55x	all(vapply(stan_lists, is.list, logical(1)))
102		)
103	55x	Reduce(append, stan_lists)
104		}
105
106
107		# merge-ParameterList,ParameterList ----
108
109		#' @rdname merge
110		setMethod(
111		f = "merge",
112		signature = c(x = "ParameterList", y = "ParameterList"),
113		definition = function(x, y) {
114	73x	parameters <- append(x@parameters, y@parameters)
115	73x	do.call(ParameterList, parameters)
116		}
117		)
118
119		# as.list-ParameterList ----
120
121		#' `ParameterList` -> `list`
122		#' @description
123		#' Returns a named list where each element of the list corresponds
124		#' to a Stan modelling block e.g. `data`, `model`, etc.
125		#' @inheritParams ParameterList-Shared
126		#' @family ParameterList
127		#' @export
128		as.list.ParameterList <- function(x, ...) {
129	96x	as.list(as.StanModule(x))
130		}
131
132
133		#' Parameter-List Getter Functions
134		#' @description
135		#' Getter functions for the slots of a [`ParameterList`] object
136		#' @inheritParams ParameterList-Shared
137		#' @family ParameterList
138		#' @typed n_chains: integer
139		#' the number of chains.
140		#' @name ParameterList-Getter-Methods
141		NULL
142
143
144		#' @describeIn ParameterList-Getter-Methods The parameter-list's parameter names
145		#' @export
146		names.ParameterList <- function(x) {
147	133x	vapply(x@parameters, names, character(1))
148		}
149
150
151		#' @describeIn ParameterList-Getter-Methods The parameter-list's parameter initial values
152		#' @export
153		initialValues.ParameterList <- function(object, n_chains, ...) {
154		# Generate initial values as a list of lists. This is to ensure it is in the required
155		# format as specified by cmdstanr see the `init` argument of
156		# `help("model-method-sample", "cmdstanr")` for more details
157	45x	lapply(
158	45x	seq_len(n_chains),
159	45x	\(i) {
160	954x	vals <- lapply(object@parameters, initialValues)
161	939x	name <- vapply(object@parameters, names, character(1))
162	939x	names(vals) <- name
163	939x	vals
164		}
165		)
166		}
167
168
169		#' @describeIn ParameterList-Getter-Methods The parameter-list's parameter dimensionality
170		#' @export
171		size.ParameterList <- function(object) {
172	18x	x <- lapply(object@parameters, size)
173	18x	names(x) <- names(object)
174	18x	return(x)
175		}
176
177
178		#' `ParameterList` -> Printable `Character`
179		#'
180		#' Converts [`ParameterList`] object into a printable string.
181		#' @inheritParams ParameterList-Shared
182		#' @family ParameterList
183		#' @keywords internal
184		#' @export
185		as_print_string.ParameterList <- function(object, ...) {
186	39x	x <- vapply(object@parameters, as.character, character(1))
187	39x	if (length(x) == 0) {
188	!	x <- "<No Parameters>"
189		}
190	39x	return(x)
191		}
192
193
194		#' @rdname show-object
195		#' @export
196		setMethod(
197		f = "show",
198		signature = "ParameterList",
199		definition = function(object) {
200	1x	chrs <- as_print_string(object)
201	1x	string <- paste(" ", chrs) \|> paste(collapse = "\n")
202	1x	x <- sprintf("\nParameterList Object:\n%s\n\n", string)
203	1x	cat(x)
204	1x	return(object)
205		}
206		)

1		#' Calculate Population Hazard Ratios
2		#'
3		#' Calculates hazard ratios marginalised over subject specific random effects using the
4		#' approach proposed by \insertCite{oudenhoven2020marginal}{jmpost}.
5		#'
6		#' @typed object: JointModelSamples
7		#' samples as drawn from a Joint Model.
8		#' @typed hr_formula: formula
9		#' defines the terms to include in the hazard ratio calculation.
10		#' By default this uses the right side of the formula used in the survival model.
11		#' Set to `NULL` not include any terms
12		#' @typed baseline: formula
13		#' terms to model baseline hazard using variable `time`.
14		#' Default is a B-spline from [splines]: `~bs(time, df = 10)`
15		#' @typed quantiles: numeric
16		#' vector of two values in (0, 1) for calculating quantiles from log hazard ratio
17		#' distributions.
18		#'
19		#' @references \insertAllCited{}
20		#'
21		#' @returns A list containing a summary of parameter distributions as a `data.frame` and a
22		#' matrix containing the parameter estimates for each sample.
23		#' @export
24		#' @importFrom splines bs
25		populationHR <- function(
26		object,
27		hr_formula = object@data@survival@formula,
28		baseline = ~ bs(time, df = 10),
29		quantiles = c(0.025, 0.975)
30		) {
31	8x	assert_class(object, "JointModelSamples")
32	7x	assert_formula(hr_formula)
33	6x	assert_formula(baseline)
34	6x	assert_numeric(
35	6x	quantiles,
36	6x	lower = 0,
37	6x	upper = 1,
38	6x	any.missing = FALSE,
39	6x	unique = TRUE
40		)
41	5x	if (!"time" %in% all.vars(baseline)) {
42	1x	stop("baseline formula should include a time term.")
43		}
44
45		# Extract the variable names used in the data
46	4x	subject_var <- object@data@subject@subject
47	4x	arm_var <- object@data@subject@arm
48	4x	long_time_var <- all.vars(delete.response(terms(
49	4x	object@data@longitudinal@formula
50		)))
51	4x	surv_time_var <- all.vars(object@data@survival@formula[[2]][[2]])
52	4x	surv_covs <- all.vars(delete.response(terms(hr_formula)))
53	4x	if (!all(surv_covs %in% colnames(object@data@survival@data))) {
54	1x	stop("All variables in hr_formula must be in survival data")
55		}
56
57	3x	marginal_formula <- stats::reformulate(c(
58	3x	attr(terms(baseline), "term.labels"),
59	3x	attr(terms(hr_formula), "term.labels")
60		))
61
62		# Get the survival quantities at the observed longitudinal and survival times for each patient:
63	3x	times_df <- rbind(
64	3x	stats::setNames(
65	3x	object@data@longitudinal@data[, c(subject_var, long_time_var)],
66	3x	c("subject", "time")
67		),
68	3x	stats::setNames(
69	3x	object@data@survival@data[, c(subject_var, surv_time_var)],
70	3x	c("subject", "time")
71		)
72		)
73	3x	times_df <- times_df[order(times_df$subject, times_df$time), ]
74	3x	times_df <- times_df[times_df$time > 0, ]
75	3x	times_df <- times_df[!duplicated.data.frame(times_df), ]
76
77		# Generate samples of the log hazard log h_i(t) for each patient i at these time points t.
78	3x	grid_spec <- split(times_df$time, times_df$subject)
79	3x	log_haz_samples <- SurvivalQuantities(
80	3x	object,
81	3x	grid = GridManual(grid_spec),
82	3x	type = "loghaz"
83	3x	)@quantities@quantities \|>
84	3x	t()
85
86		# Construct \tilde{X} in paper's notation with one row per patient's time
87	3x	W_df <- dplyr::left_join(
88	3x	times_df,
89	3x	stats::setNames(
90	3x	object@data@survival@data[, c(subject_var, surv_covs)],
91	3x	c("subject", surv_covs)
92		),
93	3x	by = "subject"
94		)
95	3x	W_mat <- model.matrix(marginal_formula, W_df)
96
97		# As model matrix contains baseline and covariates, we don't need the intercept term
98		# but we want factor variables encoded relative to the intercept
99	3x	W_mat <- W_mat[, colnames(W_mat) != "(Intercept)", drop = FALSE]
100
101	3x	estimates <- stats::lm.fit(x = W_mat, y = log_haz_samples)$coefficients
102	3x	tidy_res <- apply(estimates, 1, function(x) {
103	26x	quantiles <- stats::quantile(x, probs = quantiles)
104	26x	c(mean = mean(x), median = median(x), quantiles)
105		}) \|>
106	3x	t() \|>
107	3x	data.frame()
108
109	3x	list(summary = tidy_res, estimates)
110		}

1		#' `SimSurvival` Function Arguments
2		#'
3		#' The documentation lists all the conventional arguments for [`SimSurvival`]
4		#' constructors.
5		#'
6		#' @typed time_max: number
7		#' the maximum time to simulate to.
8		#' @typed time_step: number
9		#' the time interval between evaluating the log-hazard function.
10		#' @typed lambda_censor: number
11		#' the censoring rate.
12		#' @typed beta_cont: number
13		#' the continuous covariate coefficient.
14		#' @typed beta_cat: numeric
15		#' the categorical covariate coefficients.
16		#' @typed loghazard: function
17		#' the log hazard function.
18		#' @typed name: character
19		#' the name of the object.
20		#' @param ... Not Used.
21		#'
22		#' @section Hazard Evaluation:
23		#'
24		#' Event times are simulated by sampling a cumulative hazard limit from a \eqn{U(0, 1)} distribution
25		#' for
26		#' each subject and then counting how much hazard they've been exposed to by evaluating the
27		#' log-hazard function at a set interval. The `time_max` argument sets the upper bound for the
28		#' number of time points to evaluate the log-hazard function at with subjects who have not had an
29		#' event being censored at `time_max`. The `time_step` argument sets the interval at which to
30		#' evaluate the log-hazard function. Setting smaller values for `time_step` will increase the
31		#' precision of the simulation at the cost of increased computation time. Likewise, setting large
32		#' values for `time_max` will minimize the number of censored subjects at the cost of
33		#' increased computation time.
34		#'
35		#' @name SimSurvival-Shared
36		#' @keywords internal
37		NULL
38
39
40		#' Abstract Simulation Class for Survival Data
41		#'
42		#' @inheritParams SimSurvival-Shared
43		#' @inheritSection SimSurvival-Shared Hazard Evaluation
44		#'
45		#' @slot time_max (`numeric`)\cr See arguments.
46		#' @slot time_step (`numeric`)\cr See arguments.
47		#' @slot lambda_censor (`numeric`)\cr See arguments.
48		#' @slot beta_cont (`numeric`)\cr See arguments.
49		#' @slot beta_cat (`numeric`)\cr See arguments.
50		#' @slot loghazard (`function`)\cr See arguments.
51		#' @slot name (`character`)\cr See arguments.
52		#' @slot beta_os_cov (`numeric`) Additional regression coefficients for survival models.
53		#'
54		#' @family SimSurvival
55		#' @exportClass SimSurvival
56		#' @name SimSurvival-class
57		.SimSurvival <- setClass(
58		"SimSurvival",
59		slots = c(
60		time_max = "numeric",
61		time_step = "numeric",
62		lambda_censor = "numeric",
63		beta_cont = "numeric",
64		beta_cat = "numeric",
65		beta_os_cov = "numeric",
66		loghazard = "function",
67		name = "character"
68		)
69		)
70
71		#' @rdname SimSurvival-class
72		#' @export
73		SimSurvival <- function(
74		time_max = 2000,
75		time_step = 1,
76		lambda_censor = 1 / 3000,
77		beta_cont = 0.2,
78		beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2),
79		loghazard,
80		name = "SimSurvival"
81		) {
82	30x	.SimSurvival(
83	30x	time_max = time_max,
84	30x	time_step = time_step,
85	30x	lambda_censor = lambda_censor,
86	30x	beta_cont = beta_cont,
87	30x	beta_cat = beta_cat,
88	30x	loghazard = loghazard,
89	30x	name = name
90		)
91		}
92
93
94		#' @rdname show-object
95		#' @export
96		setMethod(
97		f = "show",
98		signature = "SimSurvival",
99		definition = function(object) {
100	4x	x <- sprintf("\nA %s Object\n\n", as_print_string(object))
101	4x	cat(x)
102	4x	return(object)
103		}
104		)
105
106		#' @rdname as_print_string
107		#' @exportS3Method NULL
108		as_print_string.SimSurvival <- function(object, ...) {
109	4x	return(object@name)
110		}
111
112
113		#' Construct Time Intervals
114		#'
115		#' @typed object: SimSurvival
116		#' the survival simulation object to create evaluation points for.
117		#' @param ... Not Used.
118		#'
119		#' @return A `tibble` with `lower`, `upper`, `time`, `eval` and `width`.
120		#' @keywords internal
121		#' @exportS3Method NULL
122		hazardWindows.SimSurvival <- function(object, ...) {
123	24x	times <- seq(0, object@time_max, object@time_step)
124	24x	bound_lower <- times[-length(times)]
125	24x	bound_upper <- times[-1]
126	24x	bound_width <- bound_upper - bound_lower
127	24x	mid_point <- bound_upper - (bound_width / 2)
128	24x	tibble::tibble(
129	24x	lower = bound_lower,
130	24x	upper = bound_upper,
131	24x	midpoint = mid_point,
132	24x	width = bound_width
133		)
134		}
135
136		#' @rdname sampleSubjects
137		#' @export
138		sampleSubjects.SimSurvival <- function(object, subjects_df) {
139	24x	subjects_df \|>
140	24x	dplyr::mutate(cov_cont = stats::rnorm(dplyr::n())) \|>
141	24x	dplyr::mutate(
142	24x	cov_cat = factor(
143	24x	sample(
144	24x	names(object@beta_cat),
145	24x	replace = TRUE,
146	24x	size = dplyr::n()
147		),
148	24x	levels = names(object@beta_cat)
149		)
150		) \|>
151	24x	dplyr::mutate(
152	24x	log_haz_cov = .data$cov_cont *
153	24x	object@beta_cont +
154	24x	object@beta_cat[.data$cov_cat]
155		) \|>
156	24x	dplyr::mutate(survival = stats::runif(dplyr::n())) \|>
157	24x	dplyr::mutate(chazard_limit = -log(.data$survival)) \|>
158	24x	dplyr::mutate(time_cen = stats::rexp(dplyr::n(), object@lambda_censor))
159		}
160
161
162		#' @rdname sampleObservations
163		#' @export
164		sampleObservations.SimSurvival <- function(object, times_df) {
165	24x	assert_that(
166	24x	all(times_df$time >= 0),
167	24x	msg = "All time points must be greater than or equal to 0"
168		)
169
170	24x	os_dat_chaz <- times_df \|>
171	24x	dplyr::mutate(log_bl_haz = object@loghazard(.data$midpoint)) \|>
172		# Fix to avoid issue with log(0) = NaN values
173	24x	dplyr::mutate(
174	24x	log_bl_haz = dplyr::if_else(
175	24x	.data$midpoint == 0,
176	24x	-999,
177	24x	.data$log_bl_haz
178		)
179		) \|>
180	24x	dplyr::mutate(
181	24x	hazard_instant = exp(
182	24x	.data$log_bl_haz + .data$log_haz_cov + .data$log_haz_link
183		)
184		) \|>
185		# Reset Inf values to large number to avoid NaN issues downstream
186		# This is suitable as Hazard limits tend to be in the range of -10 to 10 so large numbers
187		# are essentially equivalent to infinity for simulation purposes
188	24x	dplyr::mutate(
189	24x	hazard_instant = dplyr::if_else(
190	24x	.data$hazard_instant == Inf,
191	24x	999,
192	24x	.data$hazard_instant
193		)
194		) \|>
195	24x	dplyr::mutate(
196	24x	hazard_instant = dplyr::if_else(
197	24x	.data$hazard_instant == -Inf,
198	24x	-999,
199	24x	.data$hazard_instant
200		)
201		) \|>
202	24x	dplyr::mutate(hazard_interval = .data$hazard_instant * .data$width) \|>
203	24x	dplyr::group_by(.data$subject) \|>
204	24x	dplyr::mutate(chazard = cumsum(.data$hazard_interval)) \|>
205	24x	dplyr::ungroup()
206
207	24x	os_had_event <- os_dat_chaz \|>
208	24x	dplyr::filter(.data$chazard >= .data$chazard_limit) \|>
209	24x	dplyr::group_by(.data$subject) \|>
210	24x	dplyr::slice(1) \|>
211	24x	dplyr::ungroup() \|>
212	24x	dplyr::mutate(event = 1)
213
214	24x	os_had_censor <- os_dat_chaz \|>
215	24x	dplyr::filter(!.data$subject %in% os_had_event$subject) \|>
216	24x	dplyr::group_by(.data$subject) \|>
217	24x	dplyr::slice(dplyr::n()) \|>
218	24x	dplyr::ungroup() \|>
219	24x	dplyr::mutate(event = 0)
220
221	24x	if (!(nrow(os_had_censor) == 0)) {
222	8x	message(sprintf(
223	8x	"INFO: %i subject(s) did not die before max(times)",
224	8x	nrow(os_had_censor)
225		))
226		}
227
228	24x	os_dat_complete <- os_had_event \|>
229	24x	dplyr::bind_rows(os_had_censor) \|>
230	24x	dplyr::mutate(real_time = .data$time) \|>
231	24x	dplyr::mutate(
232	24x	event = dplyr::if_else(
233	24x	.data$real_time <= .data$time_cen,
234	24x	.data$event,
235	24x	0
236		)
237		) \|>
238	24x	dplyr::mutate(
239	24x	time = dplyr::if_else(
240	24x	.data$real_time <= .data$time_cen,
241	24x	.data$real_time,
242	24x	.data$time_cen
243		)
244		) \|>
245	24x	dplyr::arrange(.data$subject)
246
247	24x	keep_cols <- colnames(os_dat_complete) %in%
248	24x	c("subject", "study", "arm", "time", "event", "cov_cont", "cov_cat")
249	24x	os_dat_complete[, keep_cols]
250		}
251
252
253		#' Simulate Survival Data from a Weibull Proportional Hazard Model
254		#'
255		#' @typed lambda: number
256		#' the scale parameter.
257		#' @typed gamma: number
258		#' the shape parameter.
259		#'
260		#' @inheritParams SimSurvival-Shared
261		#' @inheritSection SimSurvival-Shared Hazard Evaluation
262		#'
263		#' @family SimSurvival
264		#'
265		#' @export
266		SimSurvivalWeibullPH <- function(
267		lambda,
268		gamma,
269		time_max = 2000,
270		time_step = 1,
271		lambda_censor = 1 / 3000,
272		beta_cont = 0.2,
273		beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2)
274		) {
275	4x	SimSurvival(
276	4x	time_max = time_max,
277	4x	time_step = time_step,
278	4x	lambda_censor = lambda_censor,
279	4x	beta_cont = beta_cont,
280	4x	beta_cat = beta_cat,
281	4x	loghazard = function(time) {
282	3x	log(lambda) + log(gamma) + (gamma - 1) * log(time)
283		},
284	4x	name = "SimSurvivalWeibullPH"
285		)
286		}
287
288		#' Simulate Survival Data from a Log-Logistic Proportional Hazard Model
289		#'
290		#' @typed a: number
291		#' the scale parameter.
292		#' @typed b: number
293		#' the shape parameter.
294		#'
295		#' @inheritParams SimSurvival-Shared
296		#' @inheritSection SimSurvival-Shared Hazard Evaluation
297		#'
298		#' @family SimSurvival
299		#' @export
300		SimSurvivalLogLogistic <- function(
301		a,
302		b,
303		time_max = 2000,
304		time_step = 1,
305		lambda_censor = 1 / 3000,
306		beta_cont = 0.2,
307		beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2)
308		) {
309	2x	SimSurvival(
310	2x	time_max = time_max,
311	2x	time_step = time_step,
312	2x	lambda_censor = lambda_censor,
313	2x	beta_cont = beta_cont,
314	2x	beta_cat = beta_cat,
315	2x	loghazard = function(time) {
316	1x	c1 <- -log(a) + log(b) + (b - 1) * (-log(a) + log(time))
317	1x	c2 <- log(1 + (time / a)^b)
318	1x	return(c1 - c2)
319		},
320	2x	name = "SimSurvivalLogLogistic"
321		)
322		}
323
324
325		#' Simulate Survival Data from a Exponential Proportional Hazard Model
326		#'
327		#' @typed lambda: number
328		#' the rate parameter.
329		#'
330		#' @inheritParams SimSurvival-Shared
331		#' @inheritSection SimSurvival-Shared Hazard Evaluation
332		#'
333		#' @family SimSurvival
334		#'
335		#' @export
336		SimSurvivalExponential <- function(
337		lambda,
338		time_max = 2000,
339		time_step = 1,
340		lambda_censor = 1 / 3000,
341		beta_cont = 0.2,
342		beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2)
343		) {
344	22x	SimSurvival(
345	22x	time_max = time_max,
346	22x	time_step = time_step,
347	22x	lambda_censor = lambda_censor,
348	22x	beta_cont = beta_cont,
349	22x	beta_cat = beta_cat,
350	22x	loghazard = function(time) {
351	21x	log(lambda)
352		},
353	22x	name = "SimSurvivalExponential"
354		)
355		}
356
357
358		#' Simulate Survival Data from a Gamma Proportional Hazard Model
359		#'
360		#' @typed k: number
361		#' the shape parameter.
362		#' @typed theta: number
363		#' the scale parameter.
364		#'
365		#' @inheritParams SimSurvival-Shared
366		#' @inheritSection SimSurvival-Shared Hazard Evaluation
367		#'
368		#' @family SimSurvival
369		#'
370		#' @importFrom stats dgamma pgamma
371		#'
372		#' @export
373		SimSurvivalGamma <- function(
374		k,
375		theta,
376		time_max = 2000,
377		time_step = 1,
378		lambda_censor = 1 / 3000,
379		beta_cont = 0.2,
380		beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2)
381		) {
382	1x	SimSurvival(
383	1x	time_max = time_max,
384	1x	time_step = time_step,
385	1x	lambda_censor = lambda_censor,
386	1x	beta_cont = beta_cont,
387	1x	beta_cat = beta_cat,
388	1x	loghazard = function(time) {
389	1x	dgamma(time, k, scale = theta, log = TRUE) -
390	1x	pgamma(time, k, scale = theta, lower.tail = FALSE, log.p = TRUE)
391		},
392	1x	name = "SimSurvivalGamma"
393		)
394		}

1		#' Abstract Simulation Class for Longitudinal Data
2		#'
3		#' @typed times: numeric
4		#' the times to generate observations at.
5		#'
6		#' @description
7		#' This class exists to be extended by other classes that simulate longitudinal data.
8		#' It is not intended to be used directly.
9		#' @name SimLongitudinal-class
10		#' @family SimLongitudinal
11		#' @exportClass SimLongitudinal
12		.SimLongitudinal <- setClass(
13		"SimLongitudinal",
14		slots = list(
15		times = "numeric"
16		)
17		)
18
19		#' @rdname SimLongitudinal-class
20		#' @export
21		SimLongitudinal <- function(times = seq(0, 100, 50)) {
22	!	.SimLongitudinal(times = times)
23		}
24
25
26		#' @rdname show-object
27		#' @export
28		setMethod(
29		f = "show",
30		signature = "SimLongitudinal",
31		definition = function(object) {
32	4x	x <- sprintf("\nA %s Object\n\n", as_print_string(object))
33	4x	cat(x)
34	4x	return(object)
35		}
36		)
37
38		#' @rdname as_print_string
39		#' @exportS3Method NULL
40		as_print_string.SimLongitudinal <- function(object, ...) {
41	!	return("SimLongitudinal")
42		}

1		#' @include SurvivalModel.R
2		NULL
3
4		# SurvivalLogLogistic-class ----
5
6		#' `SurvivalLogLogistic`
7		#'
8		#' This class extends the general [`SurvivalModel`] class for using the
9		#' log-logistic survival model.
10		#'
11		#' @exportClass SurvivalLogLogistic
12		.SurvivalLogLogistic <- setClass(
13		Class = "SurvivalLogLogistic",
14		contains = "SurvivalModel"
15		)
16
17		# SurvivalLogLogistic-constructors ----
18
19		#' @rdname SurvivalLogLogistic-class
20		#'
21		#' @typed a: Prior
22		#' Prior distribution for the scale parameter `a`.
23		#' @typed b: Prior
24		#' Prior distribution for the shape parameter `b`.
25		#' @typed beta: Prior
26		#' Prior distribution for covariates coefficients `beta`.
27		#'
28		#' @export
29		SurvivalLogLogistic <- function(
30		a = prior_lognormal(log(0.1), 5),
31		b = prior_gamma(2, 5),
32		beta = prior_normal(0, 2)
33		) {
34	9x	.SurvivalLogLogistic(
35	9x	SurvivalModel(
36	9x	name = "Log-Logistic",
37	9x	stan = StanModule("sm-loglogistic/model.stan"),
38	9x	parameters = ParameterList(
39	9x	Parameter(name = "sm_loglogis_a", prior = a, size = 1),
40	9x	Parameter(name = "sm_loglogis_b", prior = b, size = 1),
41	9x	Parameter(
42	9x	name = "beta_os_cov",
43	9x	prior = beta,
44	9x	size = "p_os_cov_design"
45		)
46		)
47		)
48		)
49		}

1		#' @include generics.R
2		NULL
3
4
5		#' Standard Links
6		#'
7		#' @typed prior: Prior
8		#' A [`Prior`] object.
9		#' @typed model: LongitudinalModel
10		#' A [`LongitudinalModel`] object.
11		#' @param ... Not used.
12		#'
13		#' @description
14		#' These functions are used to enable the use of the corresponding link function between
15		#' the survival and longitudinal models in a joint model. Note that the exact implementation
16		#' of the link function is model specific, see
17		#' \code{vignette("Statistical Specifications", package = "jmpost")} for more details.
18		#'
19		#' @name standard-link-user
20		NULL
21
22
23		#' @describeIn standard-link-user No link (fit the survival and longitudinal models independently)
24		#' @export
25		linkNone <- function() {
26	1x	Link()
27		}
28
29
30		#' @describeIn standard-link-user Time to growth link
31		#' @export
32		linkTTG <- function(prior, model = PromiseLongitudinalModel(), ...) {
33	13x	UseMethod("linkTTG", model)
34		}
35		#' @export
36		linkTTG.PromiseLongitudinalModel <- function(
37		prior = prior_normal(0, 2),
38		model,
39		...
40		) {
41	6x	PromiseLinkComponent(fun = linkTTG, prior = prior, key = "link_ttg")
42		}
43		#' @export
44		linkTTG.default <- function(prior, model, ...) {
45	1x	stop(sprintf(
46	1x	"Method `linkTTG` is not available for `%s`",
47	1x	class(model)[[1]]
48		))
49		}
50
51
52		#' @describeIn standard-link-user Derivative of the SLD over time link
53		#' @export
54		linkDSLD <- function(prior, model = PromiseLongitudinalModel(), ...) {
55	43x	UseMethod("linkDSLD", model)
56		}
57		#' @export
58		linkDSLD.PromiseLongitudinalModel <- function(
59		prior = prior_normal(0, 2),
60		model,
61		...
62		) {
63	23x	PromiseLinkComponent(fun = linkDSLD, prior = prior, key = "link_dsld")
64		}
65		#' @export
66		linkDSLD.default <- function(prior, model, ...) {
67	!	stop(sprintf(
68	!	"Method `linkDSLD` is not available for `%s`",
69	!	class(model)[[1]]
70		))
71		}
72
73
74		#' @describeIn standard-link-user Current SLD value link
75		#' @export
76		linkIdentity <- function(prior, model = PromiseLongitudinalModel(), ...) {
77	15x	UseMethod("linkIdentity", model)
78		}
79		#' @export
80		linkIdentity.PromiseLongitudinalModel <- function(
81		prior = prior_normal(0, 2),
82		model,
83		...
84		) {
85	7x	PromiseLinkComponent(
86	7x	fun = linkIdentity,
87	7x	prior = prior,
88	7x	key = "link_identity"
89		)
90		}
91		#' @export
92		linkIdentity.default <- function(prior, model, ...) {
93	!	stop(sprintf(
94	!	"Method `linkIdentity` is not available for `%s`",
95	!	class(model)[[1]]
96		))
97		}
98
99
100		#' @describeIn standard-link-user Growth Parameter link
101		#' @export
102		linkGrowth <- function(prior, model = PromiseLongitudinalModel(), ...) {
103	18x	UseMethod("linkGrowth", model)
104		}
105		#' @export
106		linkGrowth.PromiseLongitudinalModel <- function(
107		prior = prior_normal(0, 2),
108		model,
109		...
110		) {
111	9x	PromiseLinkComponent(fun = linkGrowth, prior = prior, key = "link_growth")
112		}
113		#' @export
114		linkGrowth.default <- function(prior, model, ...) {
115	!	stop(sprintf(
116	!	"Method `linkGrowth` is not available for `%s`",
117	!	class(model)[[1]]
118		))
119		}
120
121
122		#' @describeIn standard-link-user Shrinkage Parameter link
123		#' @export
124		linkShrinkage <- function(prior, model = PromiseLongitudinalModel(), ...) {
125	12x	UseMethod("linkShrinkage", model)
126		}
127		#' @export
128		linkShrinkage.PromiseLongitudinalModel <- function(
129		prior = prior_normal(0, 2),
130		model,
131		...
132		) {
133	6x	PromiseLinkComponent(
134	6x	fun = linkShrinkage,
135	6x	prior = prior,
136	6x	key = "link_shrinkage"
137		)
138		}
139		#' @export
140		linkShrinkage.default <- function(prior, model, ...) {
141	!	stop(sprintf(
142	!	"Method `linkShrinkage` is not available for `%s`",
143	!	class(model)[[1]]
144		))
145		}

1		#' jmpost settings
2		#'
3		#' @description
4		#' Define settings that modify the behaviour of the `jmpost` package
5		#'
6		#' Each of the following are the name of options that can be set via:
7		#' ```
8		#' options(<option_name> = <value>)
9		#' ```
10		#'
11		#' ## `jmpost.prior_shrinkage`
12		#'
13		#' Default = `0.5`
14		#'
15		#' By default all initial values are drawn as random sample from the respective prior
16		#' distribution with a shrinkage factor towards the mean. That is:
17		#' ```
18		#' initial_value = prior_mean * prior_shrinkage + (1 - prior_shrinkage) * prior_sample
19		#' ```
20		#' This setting controls the shrinkage factor. A value of 0 means no shrinkage (i.e.
21		#' pure random draw) whilst a value of 1 means the initial value is just the mean.
22		#'
23		#' ## `jmpost.cache_dir`
24		#'
25		#' Default = `tempfile()`
26		#'
27		#' Directory to store compiled stan models in. If not set, a temporary directory is used for
28		#' the given R session. Can also be set via the environment variable `JMPOST_CACHE_DIR`.
29		#'
30		#'
31		#'
32		#' ## `jmpost.gauss_quad_n`
33		#'
34		#' Default = 15
35		#'
36		#' In most cases the survival function of the joint model does not have a closed form
37		#' and as such it is calculated by integrating the hazard function. `jmpost` estimates this
38		#' via Gaussian Quadrature, in particular it uses [`statmod::gauss.quad`] with
39		#' `kind = "legendre"` to create the nodes and weights.
40		#'
41		#' This option specifies the `n` argument in the call to [`statmod::gauss.quad`]. In general
42		#' higher values of `n` lead to better accuracy of the approximation but at the cost of
43		#' increased computational time.
44		#'
45		#' @examples
46		#' \dontrun{
47		#' options(jmpost.prior_shrinkage = 0.5)
48		#' }
49		#' @name jmpost-settings
50		set_options <- function() {
51	!	cache_dir <- Sys.getenv("JMPOST_CACHE_DIR")
52
53	!	if (cache_dir == "" \|\| is.null(cache_dir)) {
54	!	cache_dir <- tempfile()
55		}
56
57	!	current_opts <- names(options())
58	!	jmpost_opts <- list(
59	!	jmpost.cache_dir = cache_dir,
60	!	jmpost.prior_shrinkage = 0.5,
61	!	jmpost.gauss_quad_n = 15
62		)
63	!	for (opt in names(jmpost_opts)) {
64	!	if (!opt %in% current_opts) {
65	!	options(jmpost_opts[opt])
66		}
67		}
68		}

1		#' @include SurvivalModel.R
2		NULL
3
4		# SurvivalExponential-class ----
5
6		#' `SurvivalExponential`
7		#'
8		#' This class extends the general [`SurvivalModel`] class for using the
9		#' exponential survival model.
10		#'
11		#' @exportClass SurvivalExponential
12		.SurvivalExponential <- setClass(
13		Class = "SurvivalExponential",
14		contains = "SurvivalModel"
15		)
16
17		# SurvivalExponential-constructors ----
18
19		#' @rdname SurvivalExponential-class
20		#'
21		#' @typed lambda: Prior
22		#' for the exponential rate `lambda`.
23		#' @typed beta: Prior
24		#' for covariates coefficients `beta`.
25		#'
26		#' @export
27		SurvivalExponential <- function(
28		lambda = prior_gamma(2, 5),
29		beta = prior_normal(0, 2)
30		) {
31	17x	.SurvivalExponential(
32	17x	SurvivalModel(
33	17x	name = "Exponential",
34	17x	stan = StanModule("sm-exponential/model.stan"),
35	17x	parameters = ParameterList(
36	17x	Parameter(name = "sm_exp_lambda", prior = lambda, size = 1),
37	17x	Parameter(
38	17x	name = "beta_os_cov",
39	17x	prior = beta,
40	17x	size = "p_os_cov_design"
41		)
42		)
43		)
44		)
45		}

1		#' @include StanModel.R
2		NULL
3
4		# LongitudinalModel-class ----
5
6		#' `LongitudinalModel`
7		#'
8		#' This class extends the general [`StanModel`] class to comprise the longitudinal
9		#' model specification.
10		#'
11		#' @exportClass LongitudinalModel
12		.LongitudinalModel <- setClass(
13		Class = "LongitudinalModel",
14		contains = "StanModel"
15		)
16
17		# LongitudinalModel-constructors ----
18
19		#' @rdname LongitudinalModel-class
20		#'
21		#' @inheritParams stanmodel_arguments
22		#'
23		#' @export
24		LongitudinalModel <- function(
25		stan = StanModule(),
26		parameters = ParameterList(),
27		name = "<Unnamed>",
28		...
29		) {
30	96x	base_stan <- read_stan("base/longitudinal.stan")
31
32	96x	stan_full <- decorated_render(
33	96x	.x = base_stan,
34	96x	stan = add_missing_stan_blocks(as.list(stan))
35		)
36
37	96x	.LongitudinalModel(
38	96x	StanModel(
39	96x	stan = StanModule(stan_full),
40	96x	parameters = parameters,
41	96x	name = name,
42		...
43		)
44		)
45		}
46
47		#' @export
48		as_print_string.LongitudinalModel <- function(object, ...) {
49	12x	string <- sprintf(
50	12x	"\n%s Longitudinal Model with parameters:\n%s\n\n",
51	12x	object@name,
52	12x	paste(" ", as_print_string(object@parameters)) \|>
53	12x	paste(collapse = "\n")
54		)
55	12x	return(string)
56		}

1		.onAttach <- function(libname, pkgname) {
2	4x	if (!is_cmdstanr_available()) {
3	!	packageStartupMessage(
4	!	"jmpost uses cmdstanr for compiling and sampling from models, but it does not seem to be installed.\n",
5	!	"To install:\n",
6	!	"install.packages(\"cmdstanr\", repos = c(\"https://stan-dev.r-universe.dev/\", getOption(\"repos\")))"
7		)
8	4x	} else if (is.null(cmdstanr::cmdstan_version(error_on_NA = FALSE))) {
9	!	possible_paths <- unique(c(
10	!	cmdstanr::cmdstan_default_install_path(),
11	!	Sys.getenv("CMDSTAN"),
12	!	Sys.getenv("CMDSTAN_PATH"),
13	!	"/root/.cmdstan",
14	!	"~/.cmdstan"
15		))
16	!	possible_paths <- possible_paths[dir.exists(possible_paths)]
17
18	!	if (length(possible_paths)) {
19	!	for (try_path in possible_paths) {
20	!	new_path <- tryCatch(
21	!	suppressMessages(cmdstanr::set_cmdstan_path(try_path)),
22	!	warning = function(w) NULL,
23	!	error = function(e) NULL
24		)
25		}
26	!	if (!is.null(new_path)) {
27	!	packageStartupMessage("CmdStan path set to: ", new_path)
28		}
29		} else {
30	!	packageStartupMessage(
31	!	"jmpost could not identify CmdStan path. Please use cmdstanr::set_cmdstan_path()"
32		)
33		}
34		}
35	4x	return(invisible(NULL))
36		}
37
38		.onLoad <- function(...) {
39	!	set_options()
40	!	s3_register("cmdstanr::as.CmdStanMCMC", "JointModelSamples")
41		}
42
43		# This only exists to silence the false positive R CMD CHECK warning about
44		# importing but not using the posterior package. posterior is a dependency
45		# of rcmdstan that we use a lot implicitly. Also we link to their documentation
46		# pages in ours
47		.never_run <- function() {
48	!	posterior::as_draws()
49		}

1		#' Promise
2		#'
3		#' Abstract class for promise objects to inherit off of
4		#' @aliases Promise
5		#' @exportClass Promise
6		.Promise <- setClass("Promise")
7
8
9		#' Promise of a `LongitudinalModel`
10		#'
11		#' An object that promises to resolve to a [`LongitudinalModel`] object.
12		#'
13		#' @exportClass PromiseLongitudinalModel
14		.PromiseLongitudinalModel <- setClass(
15		"PromiseLongitudinalModel",
16		contains = "Promise"
17		)
18
19		#' @rdname PromiseLongitudinalModel-class
20		#' @export
21		PromiseLongitudinalModel <- function() {
22	51x	.PromiseLongitudinalModel()
23		}
24
25
26		#' Promise of a `LinkComponent`
27		#'
28		#' An object that promises to resolve to a [`LinkComponent`] object.
29		#' Inheriting from [`Promise`] and [`LinkComponent`].
30		#'
31		#' @slot fun (`function`) \cr a function that returns a `LinkComponent`. See details.
32		#'
33		#' @typed fun: function
34		#' a function that returns a `LinkComponent`. See details.
35		#' @inheritParams LinkComponent
36		#'
37		#' @details
38		#'
39		#' The `fun` slot should be a function of signature `function(prior, model)` and should return
40		#' a [`LinkComponent`] object. An error will be thrown if the returned [`LinkComponent`] object
41		#' does not have the same `key` slot value as the original `PromiseLinkComponent`.
42		#'
43		#' @exportClass PromiseLinkComponent
44		.PromiseLinkComponent <- setClass(
45		"PromiseLinkComponent",
46		contains = c("Promise", "LinkComponent"),
47		slots = list(
48		fun = "function"
49		)
50		)
51
52		#' @rdname PromiseLinkComponent-class
53		#' @export
54		PromiseLinkComponent <- function(fun, prior, key) {
55	53x	.PromiseLinkComponent(
56	53x	fun = fun,
57	53x	stan = StanModule(),
58	53x	parameters = ParameterList(Parameter(
59	53x	name = key,
60	53x	prior = prior,
61	53x	size = 1
62		)),
63	53x	key = key
64		)
65		}
66
67
68		#' @export
69		as.StanModule.PromiseLinkComponent <- function(object, model, ...) {
70	1x	resolved_object <- resolvePromise(object, model = model)
71	1x	as.StanModule(resolved_object, ...)
72		}
73
74		#' Resolve a `PromiseLinkComponent`
75		#'
76		#' Resolves a [`PromiseLinkComponent`] object to a [`LinkComponent`] object.
77		#' An error will be thrown if the returned [`LinkComponent`] object
78		#' does not have the same `key` slot value as the original [`PromiseLinkComponent`].
79		#'
80		#' @typed object: PromiseLinkComponent
81		#' the promise to resolve
82		#' @typed model: LongitudinalModel
83		#' the model to resolve the promise with
84		#' @param ... Not used.
85		#' @typedreturn LinkComponent
86		#' the resolved `LinkComponent` object
87		#'
88		#' @export
89		resolvePromise.PromiseLinkComponent <- function(object, model, ...) {
90	46x	x <- object@fun(
91	46x	prior = object@parameters@parameters[[1]]@prior,
92	46x	model = model
93		)
94	46x	assert_that(
95	46x	is(x, "LinkComponent"),
96	46x	msg = "Resolved `PromiseLinkComponent` did not produce a `LinkComponent` object"
97		)
98	46x	assert_that(
99	46x	names(object) == names(x),
100	46x	msg = paste(
101	46x	"Resolved `PromiseLinkComponent` did not produce a `LinkComponent` object",
102	46x	"with the same key as the promise"
103		)
104		)
105	45x	x
106		}