jmpost coverage - 87.95%

Files
Source

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

#' @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 declaration and prior 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 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")
    }
)

#' @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 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 (`logical`)\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 = FALSE
) {
    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))
}

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

#' 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 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 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 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 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, corresponding to a multiplicative model.
#'   As a default, the variance is not scaled by the expected value, corresponding to an additive model.
#'   (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 = FALSE,
    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 = getOption("jmpost.double_eps"))
    omega_ks <- set_limits(omega_ks, lower = getOption("jmpost.double_eps"))
    omega_kg <- set_limits(omega_kg, lower = getOption("jmpost.double_eps"))
    omega_phi <- set_limits(omega_phi, lower = getOption("jmpost.double_eps"))
    sigma <- set_limits(sigma, lower = getOption("jmpost.double_eps"))

    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 = set_limits(prior_init_only(prior_lognormal(
                    median(mu_bsld),
                    median(omega_bsld)
                )), lower = getOption("jmpost.double_eps")),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_gsf_psi_ks",
                prior = set_limits(prior_init_only(prior_lognormal(
                    median(mu_ks),
                    median(omega_ks)
                )), lower = getOption("jmpost.double_eps")),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_gsf_psi_kg",
                prior = set_limits(prior_init_only(prior_lognormal(
                    median(mu_kg),
                    median(omega_kg)
                )), lower = getOption("jmpost.double_eps")),
                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),
        scaled_variance = scaled_variance
    )
    .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"
    )
}

#' @include StanModel.R
NULL

# LongitudinalModel-class ----

#' `LongitudinalModel`
#'
#' This class extends the general [`StanModel`] class to comprise the longitudinal
#' model specification.
#'
#' @slot scaled_variance logical scalar, whether the variance should be scaled
#'   by the expected value, corresponding to a multiplicative model. If not,
#'   then an additive error model is used.
#'
#' @exportClass LongitudinalModel
.LongitudinalModel <- setClass(
    Class = "LongitudinalModel",
    contains = "StanModel",
    slots = c(
        scaled_variance = "logical"
    )
)

# LongitudinalModel-constructors ----

#' @rdname LongitudinalModel-class
#'
#' @inheritParams stanmodel_arguments
#' @typed scaled_variance: flag
#'   whether the variance should be scaled
#'   by the expected value, corresponding to a multiplicative model. If not,
#'   then an additive error model is used.
#'
#' @export
LongitudinalModel <- function(
    stan = StanModule(),
    parameters = ParameterList(),
    name = "<Unnamed>",
    scaled_variance = NA,
    ...
) {
    assert_flag(scaled_variance)
    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,
            ...
        ),
        scaled_variance = scaled_variance
    )
}

#' @export
as_print_string.LongitudinalModel <- function(object, ...) {
    string <- sprintf(
        "\n%s Longitudinal Model (%s error) with parameters:\n%s\n\n",
        object@name,
        if (is.na(object@scaled_variance)) {
            # Should not happen but just to be robust against this case.
            "unknown"
        } else if (object@scaled_variance) {
            "multiplicative"
        } else {
            "additive"
        },
        paste("   ", as_print_string(object@parameters)) |>
            paste(collapse = "\n")
    )
    return(string)
}

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


# auxiliaryInitialValues ----

#' `auxiliaryInitialValues`
#'
#' Obtain initial values for any additional Stan parameters introduced by an object.
#'
#' @param object where to get the auxiliary initial values from.
#' @param ... additional options.
#'
#' @details
#' Some objects, such as shrinkage priors, declare additional Stan parameters
#' beyond the main model parameter. This helper returns named initial values for
#' those additional parameters.
#'
#' @keywords internal
auxiliaryInitialValues <- function(object, ...) {
    UseMethod("auxiliaryInitialValues")
}


# auxiliarySize ----

#' `auxiliarySize`
#'
#' Obtain sizes for any additional Stan parameters introduced by an object.
#'
#' @param object where to get the auxiliary parameter sizes from.
#' @param ... additional options.
#'
#' @details
#' Some objects, such as shrinkage priors, declare additional Stan parameters
#' beyond the main model parameter. This helper returns named sizes for those
#' additional parameters so their initial values can be expanded consistently.
#'
#' @keywords internal
auxiliarySize <- function(object, ...) {
    UseMethod("auxiliarySize")
}


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


#' Extract Covariate Names
#'
#' @typed object: ANY
#'   the object to extract covariate names from.
#' @param ... additional arguments added by methods.
#'
#' @family covariates
#' @export
covariates <- function(object, ...) {
    UseMethod("covariates")
}

#' Extract Covariate Shrinkage Factors from the Posterior Samples
#'
#' @typed object: ANY
#'   the object to extract shrinkage factors from.
#' @param ... additional arguments added by methods.
#'
#' @family shrinkage
#' @export
shrinkage <- function(object, ...) {
    UseMethod("shrinkage")
}

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

#' 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.
#'
#' @typed object: SimJointData
#'   where the PFS events should be added.
#' @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
#' @typed object: SimJointData
#'   where the cut times should be applied.
#' @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
}

#' 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 = getOption("jmpost.double_eps"),
        machine_double_neg_eps = getOption("jmpost.double_neg_eps"),
    )
}


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

#' Simulate Patients from Posterior Predictive Distribution
#' @typed object: JointModelSamples
#'   the object containing the posterior samples.
#' @typed newdata: data.frame
#'   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
#'   Unused.
#' @typed times: numeric
#'   times to simulate SLD for all patients.
#' @typed jitter_var: numeric
#'   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.
#' @typed scaled_variance: flag
#'   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 = FALSE,
    ...
) {
    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
#' @typed draws: matrix
#'   the draws input.
#' @typed 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 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, ...)
}

#' Extract shrinkage factors from a `JointModelSamples` object
#'
#' @typed object: JointModelSamples
#'   the object to extract shrinkage factors from.
#' @param ... not used.
#' @return the shrinkage factors correctly named after the covariate names.
#'
#' @family shrinkage
#' @export
shrinkage.JointModelSamples <- function(object, ...) {
    draws <- cmdstanr::as.CmdStanMCMC(object)$draws()
    assert_class(object@data@survival, "DataSurvival")
    covariate_names <- covariates(object@data@survival)
    assert_subset(
        "prior_shrinkage_factors_beta_os_cov[1]",
        posterior::variables(draws)
    )
    shrinkage_draws <- subset(
        draws,
        variable = "prior_shrinkage_factors_beta_os_cov"
    )
    shrinkage_vars <- posterior::variables(shrinkage_draws)
    assert_true(identical(length(covariate_names), length(shrinkage_vars)))
    posterior::variables(shrinkage_draws) <- covariate_names
    shrinkage_draws
}

#' @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, corresponding to a multiplicative model.
#'   As a default, the variance is not scaled by the expected value, corresponding to an additive model.
#'   (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 = FALSE,
    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 = getOption("jmpost.double_eps"))
    omega_ks <- set_limits(omega_ks, lower = getOption("jmpost.double_eps"))
    omega_kg <- set_limits(omega_kg, lower = getOption("jmpost.double_eps"))
    sigma <- set_limits(sigma, lower = getOption("jmpost.double_eps"))

    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 = set_limits(prior_init_only(prior_lognormal(
                    median(mu_bsld),
                    median(omega_bsld)
                )), lower = getOption("jmpost.double_eps")),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_sf_psi_ks",
                prior = set_limits(prior_init_only(prior_lognormal(
                    median(mu_ks),
                    median(omega_ks)
                )), lower = getOption("jmpost.double_eps")),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_sf_psi_kg",
                prior = set_limits(prior_init_only(prior_lognormal(
                    median(mu_kg),
                    median(omega_kg)
                )), lower = getOption("jmpost.double_eps")),
                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),
        scaled_variance = scaled_variance
    )
    .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"
    )
}

#' @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)
) {
    lambda <- set_limits(lambda, lower = getOption("jmpost.double_eps"))
    .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 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 model-specific Stan code specification.
#' @typed parameters: ParameterList
#'   the parameter declaration and prior specification.
#' @typed parameter: ParameterList
#'   the (single) parameter declaration and prior 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)
}

#' @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
#' @param df (`data.frame`)\cr The data frame to be used for generating the design matrix.
#' @param vars (`list`)\cr The list of variable names to be used for generating the design matrix.
#' @export
model.matrix.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)
    if (length(remove_index) > 0) {
        design_mat <- design_mat[, -remove_index, drop = FALSE]
    }
    rownames(design_mat) <- NULL
    design_mat
}

#' Extract Covariate Names for Survival Data
#'
#' @typed object: DataSurvival
#'  Survival data object to extract covariate names from.
#' @param ... not used.
#'
#' @family covariates
#' @export
covariates.DataSurvival <- function(object, ...) {
    design_mat <- model.matrix(object, ...)
    colnames(design_mat)
}

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

    design_mat <- model.matrix(object, df = df, vars = vars)

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

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

#' @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. When converted to a [`StanModule`], the list supplies the
#' Stan declarations and prior statements for those parameters.
#'
#'

#' @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, ...) {
    parameters <- Filter(\(x) !x@prior@.is_const, object@parameters)
    # 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(parameters, function(parameter) {
                c(
                    stats::setNames(
                        list(initialValues(parameter)),
                        names(parameter)
                    ),
                    auxiliaryInitialValues(
                        parameter@prior,
                        name = names(parameter),
                        size = size(parameter)
                    )
                )
            })
            unlist(vals, recursive = FALSE)
        }
    )
}


#' @describeIn ParameterList-Getter-Methods The parameter-list's parameter dimensionality
#' @export
size.ParameterList <- function(object) {
    parameters <- Filter(\(x) !x@prior@.is_const, object@parameters)
    sizes <- lapply(parameters, function(parameter) {
        c(
            stats::setNames(list(size(parameter)), names(parameter)),
            auxiliarySize(
                parameter@prior,
                name = names(parameter),
                size = size(parameter)
            )
        )
    })
    unlist(sizes, recursive = FALSE)
}


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

#' @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 = FALSE
) {
    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)
}

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

#' 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 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 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`.
#' @typed scaled_variance: logical
#'   whether the variance should be scaled by the expected value, corresponding to a multiplicative model.
#'   As a default, the variance is not scaled by the expected value, corresponding to an additive model.
#'   (See the "Statistical Specifications" vignette for more details.)
#'
#' @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),
    scaled_variance = FALSE
) {
    stan <- StanModule(decorated_render(
        .x = read_stan("lm-random-slope/model.stan"),
        scaled_variance = scaled_variance
    ))

    # Apply constriants
    sigma <- set_limits(sigma, lower = getOption("jmpost.double_eps"))
    slope_sigma <- set_limits(slope_sigma, lower = getOption("jmpost.double_eps"))

    .LongitudinalRandomSlope(
        LongitudinalModel(
            name = "Random Slope",
            stan = stan,
            scaled_variance = scaled_variance,
            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")
}

#' @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)
) {
    a <- set_limits(a, lower = getOption("jmpost.double_eps"))
    b <- set_limits(b, lower = getOption("jmpost.double_eps"))

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

.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 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, corresponding to a multiplicative model.
#'   As a default, the variance is not scaled by the expected value, corresponding to an additive model.
#'   (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 = FALSE,
    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 = getOption("jmpost.double_eps"))
    omega_g <- set_limits(omega_g, lower = getOption("jmpost.double_eps"))
    omega_c <- set_limits(omega_c, lower = getOption("jmpost.double_eps"))
    omega_p <- set_limits(omega_p, lower = getOption("jmpost.double_eps"))
    sigma <- set_limits(sigma, lower = getOption("jmpost.double_eps"))

    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 = set_limits(prior_init_only(prior_lognormal(
                    median(mu_b),
                    median(omega_b)
                )), lower = getOption("jmpost.double_eps")),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_clbr_ind_g",
                prior = set_limits(prior_init_only(prior_lognormal(
                    median(mu_g),
                    median(omega_g)
                )), lower = getOption("jmpost.double_eps")),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_clbr_ind_c",
                prior = set_limits(prior_init_only(prior_lognormal(
                    median(mu_c),
                    median(omega_c)
                )), lower = getOption("jmpost.double_eps")),
                size = "n_subjects"
            ),
            Parameter(
                name = "lm_clbr_ind_p",
                prior = set_limits(prior_init_only(prior_lognormal(
                    median(mu_p),
                    median(omega_p)
                )), lower = getOption("jmpost.double_eps")),
                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),
        scaled_variance = scaled_variance
    )
    .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"
    )
}

#' `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 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 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.
#' @typed scaled_variance: logical
#'   whether the variance should be scaled by the expected value
#'   (see the "Statistical Specifications" vignette for more details)
#'
#' @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.
#' @slot scaled_variance (`logical`)\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",
        scaled_variance = "logical"
    )
)

#' @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,
    scaled_variance = FALSE
) {
    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,
        scaled_variance = scaled_variance
    )
}

#' @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(
            sld_mu = .data$intercept + .data$slope_ind * .data$time,
            sld_sd = ifelse(
                object@scaled_variance,
                pmax(.data$sld_mu * object@sigma, .Machine$double.eps),
                object@sigma
            ),
            sld = stats::rnorm(dplyr::n(), .data$sld_mu, .data$sld_sd),
            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 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
}

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

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

#' @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 = FALSE
) {
    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 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)
}

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

#' 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.
#'
#' ## `jmpost.double_eps` and `jmpost.double_neg_eps`
#'
#' Default = `0` and `sqrt(.Machine$double.neg.eps)`
#'
#' These are small floating-point numbers `x` which are used in parameter
#' definitions as lower boundaries to prevent numerical issues with the MCMC
#' sampler in the beginning of the sampling process.
#'
#' @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,
        jmpost.double_eps = 0,
        jmpost.double_neg_eps = sqrt(.Machine$double.neg.eps)
    )
    for (opt in names(jmpost_opts)) {
        if (!opt %in% current_opts) {
            options(jmpost_opts[opt])
        }
    }
}

#' 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 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 = getOption("jmpost.double_eps"))
    gamma <- set_limits(gamma, lower = getOption("jmpost.double_eps"))

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

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

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

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

#' @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 = getOption("jmpost.double_eps"))
    theta <- set_limits(theta, lower = getOption("jmpost.double_eps"))

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

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 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		#' 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		#' @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 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	15x	UseMethod("linkTTG", model)
34		}
35		#' @export
36		linkTTG.PromiseLongitudinalModel <- function(
37		prior = prior_normal(0, 2),
38		model,
39		...
40		) {
41	7x	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	49x	UseMethod("linkDSLD", model)
56		}
57		#' @export
58		linkDSLD.PromiseLongitudinalModel <- function(
59		prior = prior_normal(0, 2),
60		model,
61		...
62		) {
63	26x	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	20x	UseMethod("linkGrowth", model)
104		}
105		#' @export
106		linkGrowth.PromiseLongitudinalModel <- function(
107		prior = prior_normal(0, 2),
108		model,
109		...
110		) {
111	10x	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		#' @include StanModule.R
2		#' @include generics.R
3		#' @include ParameterList.R
4		#' @include DataJoint.R
5		#' @include DataSurvival.R
6		#' @include DataLongitudinal.R
7		#' @include LongitudinalModel.R
8		#' @include SurvivalModel.R
9		#' @include Link.R
10		#' @include constants.R
11		NULL
12
13
14		#' Re-used documentation for `JointModel-Shared`
15		#'
16		#' @typed object: JointModel
17		#' Joint model specification.
18		#' @typed x: JointModel
19		#' Joint model specification.
20		#' @param ... Not Used.
21		#'
22		#' @name JointModel-Shared
23		#' @keywords internal
24		NULL
25
26		setClassUnion("LongitudinalModel_OR_NULL", c("LongitudinalModel", "NULL"))
27		setClassUnion("SurvivalModel_OR_NULL", c("SurvivalModel", "NULL"))
28
29		# JointModel-class ----
30
31		#' Joint Model Object and Constructor Function
32		#'
33		#' @slot longitudinal ([`LongitudinalModel`] or `NULL`)\cr the longitudinal model.
34		#' @slot survival ([`SurvivalModel`] or `NULL`)\cr the survival model.
35		#' @slot link (`Link`)\cr the link.
36		#' @slot parameters (`ParameterList`)\cr the parameter declaration and prior specification.
37		#'
38		#' @family JointModel
39		#' @export JointModel
40		#' @exportClass JointModel
41		.JointModel <- setClass(
42		Class = "JointModel",
43		slots = list(
44		longitudinal = "LongitudinalModel_OR_NULL",
45		survival = "SurvivalModel_OR_NULL",
46		link = "Link",
47		parameters = "ParameterList"
48		)
49		)
50
51		#' @typed longitudinal: "`LongitudinalModel` or `NULL`"
52		#' the longitudinal model.
53		#' @typed survival: "`SurvivalModel` or `NULL`"
54		#' the survival model.
55		#' @typed link: Link
56		#' the link.
57		#' @rdname JointModel-class
58		JointModel <- function(
59		longitudinal = NULL,
60		survival = NULL,
61		link = Link()
62		) {
63	64x	link <- resolvePromise(Link(link), longitudinal)
64
65	64x	if (length(link) > 0) {
66	24x	longitudinal <- enableLink(longitudinal)
67		}
68
69	64x	parameters <- Reduce(
70	64x	merge,
71	64x	list(
72	64x	getParameters(longitudinal),
73	64x	getParameters(survival),
74	64x	getParameters(link)
75		)
76		)
77
78	64x	.JointModel(
79	64x	longitudinal = longitudinal,
80	64x	survival = survival,
81	64x	link = link,
82	64x	parameters = parameters
83		)
84		}
85
86
87		#' @export
88		enableGQ.JointModel <- function(object, ...) {
89	44x	merge(
90	44x	enableGQ(object@survival),
91	44x	enableGQ(object@longitudinal)
92		)
93		}
94
95
96		#' `JointModel` -> `StanModule`
97		#'
98		#' Converts a [`JointModel`] object to a [`StanModule`] object
99		#'
100		#' @inheritParams JointModel-Shared
101		#' @family JointModel
102		#' @family as.StanModule
103		#' @export
104		as.StanModule.JointModel <- function(object, ...) {
105	103x	base_model <- read_stan("base/base.stan")
106
107	103x	stan_full <- decorated_render(
108	103x	.x = base_model,
109	103x	longitudinal = add_missing_stan_blocks(as.list(object@longitudinal)),
110	103x	survival = add_missing_stan_blocks(as.list(object@survival)),
111	103x	link = add_missing_stan_blocks(as.list(object@link)),
112	103x	priors = add_missing_stan_blocks(as.list(object@parameters)),
113	103x	has_os_submodel = !is.null(object@survival),
114	103x	has_long_submodel = !is.null(object@longitudinal)
115		)
116		# Unresolved Jinja code within the longitudinal / Survival / Link
117		# models won't be resolved by the above call to `decorated_render`.
118		# Instead they it will just be inserted into the template asis. Thus
119		# we run `decorated_render` again to resolve any lingering Jinja code
120		# Main example being models that don't have any Jinja code but still
121		# use the `decorated_render` constants `machine_double_eps`.
122	103x	stan_full <- decorated_render(.x = stan_full)
123
124	103x	merge(
125	103x	StanModule("base/functions.stan"),
126	103x	StanModule(stan_full)
127		)
128		}
129
130
131		#' `JointModel` -> `character`
132		#'
133		#' Renders a [`JointModel`] object to a stan program
134		#'
135		#' @inheritParams JointModel-Shared
136		#' @family JointModel
137		#' @export
138		as.character.JointModel <- function(x, ...) {
139	10x	as.character(as.StanModule(x))
140		}
141
142
143		# write_stan-JointModel ----
144
145		#' @rdname write_stan
146		#' @export
147		write_stan.JointModel <- function(object, destination, ...) {
148	!	if (is_connection(destination)) {
149	!	return(writeLines(as.character(object), con = destination))
150		}
151	!	fi <- file(destination, open = "w")
152	!	writeLines(as.character(object), con = fi)
153	!	close(fi)
154		}
155
156
157		# compileStanModel-JointModel ----
158
159		#' @rdname compileStanModel
160		#' @export
161		compileStanModel.JointModel <- function(object) {
162	18x	object \|>
163	18x	as.StanModule() \|>
164	18x	compileStanModel() \|>
165	18x	invisible()
166		}
167
168
169		# sampleStanModel-JointModel ----
170
171		#' @rdname sampleStanModel
172		#'
173		#' @typed data: "`DataJoint` or `list`"
174		#' input data.
175		#' @export
176		sampleStanModel.JointModel <- function(object, data, ...) {
177	18x	assert_class(data, "DataJoint")
178
179	18x	if (!is.null(object@survival)) {
180	14x	assert_that(
181	14x	!is.null(data@survival),
182	14x	msg = "`DataSurvival` can't be missing if a `SurvivalModel` has been specified"
183		)
184		}
185	18x	if (!is.null(object@longitudinal)) {
186	15x	assert_that(
187	15x	!is.null(data@longitudinal),
188	15x	msg = "`DataLongitudinal` can't be missing if a `LongitudinalModel` has been specified"
189		)
190		}
191
192	18x	args <- list(...)
193
194	18x	args[["data"]] <- append(
195	18x	as_stan_list(data),
196	18x	as_stan_list(object@parameters)
197		)
198
199	18x	args[["chains"]] <- if ("chains" %in% names(args)) {
200	18x	args[["chains"]]
201		} else {
202		# Magic constant from R/constants.R
203	!	CMDSTAN_DEFAULT_CHAINS
204		}
205
206	18x	initial_values <- if ("init" %in% names(args)) {
207	!	args[["init"]]
208		} else {
209	18x	initialValues(object, n_chains = args[["chains"]])
210		}
211
212	18x	args[["init"]] <- ensure_initial_values(
213	18x	initial_values,
214	18x	args[["data"]],
215	18x	object@parameters
216		)
217
218	18x	model <- compileStanModel(object)
219
220	18x	results <- do.call(
221	18x	model$sample,
222	18x	args
223		)
224
225	18x	.JointModelSamples(
226	18x	model = object,
227	18x	data = data,
228	18x	results = results
229		)
230		}
231
232
233		#' Ensure that initial values are correctly specified
234		#'
235		#' @typed initial_values: list
236		#' A list of lists containing the initial values
237		#' must be 1 list per desired chain. All elements should have identical names
238		#' @typed data: list
239		#' specifies the size to expand each of our initial values to be.
240		#' That is elements of size 1 in `initial_values` will be expanded to be the same
241		#' size as the corresponding element in `data` by broadcasting the value.
242		#' @typed parameters: ParameterList
243		#' the parameters object
244		#'
245		#' @details
246		#' This function is mostly a thin wrapper around `expand_initial_values` to
247		#' enable easier unit testing.
248		#'
249		#' @keywords internal
250		ensure_initial_values <- function(initial_values, data, parameters) {
251	20x	if (is.function(initial_values)) {
252	!	return(initial_values)
253		}
254
255	20x	assert_class(data, "list")
256	20x	assert_class(parameters, "ParameterList")
257	20x	assert_class(initial_values, "list")
258
259	20x	values_sizes <- size(parameters)
260	20x	values_sizes_complete <- replace_with_lookup(
261	20x	values_sizes,
262	20x	data
263		)
264	20x	lapply(
265	20x	initial_values,
266	20x	expand_initial_values,
267	20x	sizes = values_sizes_complete
268		)
269		}
270
271
272		#' @rdname initialValues
273		#' @export
274		initialValues.JointModel <- function(object, n_chains, ...) {
275	23x	initialValues(object@parameters, n_chains)
276		}
277
278
279		pad_with_white_space <- function(x, pad = 4) {
280	13x	padding <- paste0(rep(" ", each = pad), collapse = "")
281	13x	x_sep <- x \|>
282	13x	strsplit(split = "\n") \|>
283	13x	unlist()
284	13x	x_padded <- paste(padding, x_sep) \|>
285	13x	paste(collapse = "\n")
286	13x	return(x_padded)
287		}
288
289
290		#' @rdname show-object
291		#' @export
292		setMethod(
293		f = "show",
294		signature = "JointModel",
295		definition = function(object) {
296	5x	survival_string <- if (is.null(object@survival)) {
297	1x	"\n Not Specified\n"
298		} else {
299	4x	as_print_string(object@survival) \|> pad_with_white_space()
300		}
301
302	5x	longitudinal_string <- if (is.null(object@longitudinal)) {
303	1x	"\n Not Specified\n"
304		} else {
305	4x	as_print_string(object@longitudinal) \|> pad_with_white_space()
306		}
307
308	5x	link_string <- as_print_string(object@link) \|> pad_with_white_space()
309
310	5x	string <- "\nA Joint Model with:\n\n Survival:%s\n Longitudinal:%s\n Link:%s\n"
311	5x	cat(sprintf(
312	5x	string,
313	5x	survival_string,
314	5x	longitudinal_string,
315	5x	link_string
316		))
317		}
318		)
319
320
321		#' @rdname getRandomEffectsNames
322		#' @export
323		getRandomEffectsNames.JointModel <- function(object, ...) {
324	1x	if (is.null(object@longitudinal)) {
325	!	return(NULL)
326		}
327	1x	getRandomEffectsNames(object@longitudinal)
328		}

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	334x	vars <- extractVariableNames(object@subject)
158	334x	subject_var <- vars$subject
159	334x	as_stan_list(object@subject) \|>
160	334x	append(as_stan_list(object@survival)) \|>
161	334x	append(as_stan_list(
162	334x	object@longitudinal,
163	334x	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		#' @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	575x	for (block in names(stan_blocks)) {
39	4020x	if (is.null(x[[block]])) {
40	223x	x[[block]] <- ""
41		}
42		}
43	575x	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	5292x	assert_that(
87	5292x	is.character(x),
88	5292x	length(x) == 1,
89	5292x	msg = "`x` must be a length 1 character vector"
90		)
91	5292x	code <- read_stan(x)
92	5292x	code_fragments <- as_stan_fragments(code)
93
94		if (
95	5289x	paste0(unlist(code_fragments), collapse = "") == "" &&
96	5289x	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	5289x	.StanModule(
104	5289x	functions = code_fragments$functions,
105	5289x	data = code_fragments$data,
106	5289x	transformed_data = code_fragments$transformed_data,
107	5289x	parameters = code_fragments$parameters,
108	5289x	transformed_parameters = code_fragments$transformed_parameters,
109	5289x	model = code_fragments$model,
110	5289x	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	655x	as_stan_file(
128	655x	functions = x@functions,
129	655x	data = x@data,
130	655x	transformed_data = x@transformed_data,
131	655x	parameters = x@parameters,
132	655x	transformed_parameters = x@transformed_parameters,
133	655x	model = x@model,
134	655x	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	2263x	stan_fragments <- lapply(
149	2263x	names(stan_blocks),
150	2263x	\(par) {
151	15841x	if (all(slot(y, par) == "")) {
152	10782x	return(slot(x, par))
153		}
154	5059x	if (all(slot(x, par) == "")) {
155	2403x	return(slot(y, par))
156		}
157	2656x	return(c(slot(x, par), slot(y, par)))
158		}
159		)
160	2263x	names(stan_fragments) <- names(stan_blocks)
161	2263x	stan_code <- do.call(as_stan_file, stan_fragments)
162	2263x	StanModule(
163	2263x	x = stan_code
164		)
165		}
166		)
167
168		# compileStanModel-StanModule,character ----
169
170		#' @rdname compileStanModel
171		#' @exportS3Method NULL
172		compileStanModel.StanModule <- function(object) {
173	55x	exe_dir <- getOption("jmpost.cache_dir")
174	55x	if (!dir.exists(exe_dir)) {
175	3x	dir.create(exe_dir, recursive = TRUE)
176		}
177	55x	stan_code <- as.character(object)
178	55x	hash_name <- digest::digest(stan_code, "md5")
179	55x	exe_name <- paste0(
180	55x	"model_",
181	55x	hash_name,
182	55x	if (is_windows()) ".exe" else ""
183		)
184	55x	exe_file <- file.path(exe_dir, exe_name)
185	55x	source_file <- cmdstanr::write_stan_file(
186	55x	code = stan_code,
187	55x	dir = exe_dir,
188	55x	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	55x	withCallingHandlers(
194		{
195	55x	x <- cmdstanr::cmdstan_model(
196	55x	stan_file = source_file,
197	55x	exe_file = exe_file,
198	55x	quiet = TRUE
199		)
200		},
201	55x	message = function(m) {
202	!	if (m$message == "Model executable is up to date!\n") {
203	!	invokeRestart("muffleMessage")
204		}
205		}
206		)
207	55x	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	542x	string <- as.character(x)
226	542x	li <- as_stan_fragments(string)
227	542x	for (block in names(stan_blocks)) {
228	3794x	li[[block]] <- paste(li[[block]], collapse = "\n")
229		}
230	542x	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	17149x	if (is.null(filename)) {
247	!	return(FALSE)
248		}
249	17149x	assert_that(
250	17149x	is.character(filename),
251	17149x	length(filename) == 1,
252	17149x	msg = "`filename` must be a length 1 character"
253		)
254	17149x	if (nchar(filename) > 1000) {
255	2549x	return(FALSE)
256		}
257	14600x	if (is.na(filename)) {
258	!	return(FALSE)
259		}
260	14600x	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	5725x	local_inst_file <- file.path("inst", "stan", string)
271	5725x	system_file <- system.file(file.path("stan", string), package = "jmpost")
272	5725x	local_file <- string
273	5725x	files <- c(local_file, local_inst_file, system_file)
274	5725x	for (fi in files) {
275	17149x	if (is_file(fi)) {
276	906x	string <- readLines(fi)
277	906x	break
278		}
279		}
280	5725x	string <- paste0(string, collapse = "\n")
281	5725x	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	2918x	block_strings <- lapply(
319	2918x	names(stan_blocks),
320	2918x	function(id) {
321	20426x	char <- get(id)
322	20426x	if (any(nchar(char) >= 1)) {
323	9388x	return(sprintf(
324	9388x	"%s {\n%s\n}\n\n",
325	9388x	stan_blocks[[id]],
326	9388x	paste(char, collapse = "\n")
327		))
328		} else {
329	11038x	return("")
330		}
331		}
332		)
333	2918x	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	5834x	code <- unlist(stringr::str_split(x, "\n"))
366
367	5834x	errmsg <- paste(
368	5834x	"There were problems parsing the `%s` block.",
369	5834x	"Please consult the `Formatting Stan Files` section of the",
370	5834x	"`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	5834x	for (block in stan_blocks) {
376	40833x	regex <- sprintf("^\\s%s\\s\\{\\s*[^\\s-]+", block)
377	40833x	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	5832x	results <- list()
386	5832x	target <- NULL
387	5832x	for (line in code) {
388	310348x	for (block in names(stan_blocks)) {
389	2122896x	regex <- sprintf("^\\s%s\\s\\{\\s*$", stan_blocks[[block]])
390	2122896x	if (stringr::str_detect(line, regex)) {
391	17112x	target <- block
392	17112x	line <- NULL
393	17112x	break
394		}
395		}
396	310348x	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	308843x	results[[target]] <- c(results[[target]], line)
401		}
402		}
403
404		# Loop over each block to remove trailing "}".
405	5832x	for (block in names(results)) {
406	17111x	block_length <- length(results[[block]])
407		# The following processing is only required if the block actually has content
408	17111x	if (block_length == 1 && results[[block]] == "") {
409	!	next
410		}
411	17111x	has_removed_char <- FALSE
412		# Walk backwards to find the closing `}` that corresponds to the `<block> {`
413	17111x	for (index in rev(seq_len(block_length))) {
414	32775x	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	32775x	if (stringr::str_detect(line, "[\\w\\d]+\\s*$")) {
419	1x	stop(sprintf(errmsg, block))
420		}
421	32774x	if (stringr::str_detect(line, "\\}\\s*$")) {
422	17110x	new_line <- stringr::str_replace(line, "\\s\\}\\s$", "")
423		# If the line is now blank after removing the closing `}` then drop the line
424	17110x	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	17110x	keep_range <- seq_len(index + keep_offset)
429	17110x	results[[block]][[index]] <- new_line
430	17110x	results[[block]] <- results[[block]][keep_range]
431	17110x	has_removed_char <- TRUE
432	17110x	break
433		}
434		}
435		# If we haven't actually removed a closing `}` then something has gone wrong...
436	17110x	if (!has_removed_char) {
437	!	stop(sprintf(errmsg, block))
438		}
439		}
440
441		# Add any missing blocks back in
442	5831x	for (block in names(stan_blocks)) {
443	40817x	if (is.null(results[[block]])) {
444	23707x	results[[block]] <- ""
445		}
446		}
447	5831x	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 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 (`logical`)\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 = FALSE
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		#' @include DataJoint.R
2		#' @include Quantities.R
3		NULL
4
5
6		#' Re-used documentation for `SurvivalQuantities`
7		#'
8		#' @typed object: SurvivalQuantities
9		#' survival quantities.
10		#' @typed x: SurvivalQuantities
11		#' survival quantities.
12		#' @param ... not used.
13		#'
14		#' @keywords internal
15		#' @name SurvivalQuantities-Shared
16		NULL
17
18
19		#' `SurvivalQuantities` Object & Constructor Function
20		#'
21		#' Constructor function to generate a `SurvivalQuantities` object.
22		#'
23		#' @slot quantities (`Quantities`)\cr The sampled quantities. Should contain 1 element per
24		#' element of `group`
25		#' @slot groups (`list`)\cr See argument section for details
26		#' @slot type (`character`)\cr See See argument section for details
27		#' @slot time_grid (`numeric`)\cr See argument section for details
28		#' @slot data ([`DataJoint`])\cr The data that the Joint Model was fitted to to produce
29		#' the samples/quantities
30		#'
31		#' @section Group Specification:
32		#' If `groups` is a character vector of subject IDs then the survival quantities will
33		#' only be calculated for those specific subjects.
34		#'
35		#' If `groups` is a list then any elements with more than 1 subject ID will be grouped together
36		#' and their quantities will be calculated by taking a point-wise average.
37		#' For example: `groups = list("g1" = c("sub1", "sub2"), "g2" = c("sub3", "sub4"))` would result
38		#' in 2 groups being created whose values are the pointwise average
39		#' of `c("sub1", "sub2")` and `c("sub3", "sub4")` respectively.
40		#'
41		#' If `groups=NULL` then all subjects from original dataset will be selected
42		#'
43		#' @family SurvivalQuantities
44		#' @name SurvivalQuantities-class
45		#' @export SurvivalQuantities
46		.SurvivalQuantities <- setClass(
47		Class = "SurvivalQuantities",
48		slots = c(
49		"quantities" = "Quantities",
50		"grid" = "Grid",
51		"type" = "character",
52		"data" = "DataJoint"
53		)
54		)
55
56		#' @typed object: JointModelSamples
57		#' samples as drawn from a Joint Model.
58		#'
59		#' @typed grid: Grid
60		#' object that specifies which subjects and time points to calculate the
61		#' quantities for. See [Grid-Functions].
62		#'
63		#' @typed type: character
64		#' quantity to be generated.
65		#' Must be one of `surv`, `haz`, `loghaz`, `cumhaz`.
66		#'
67		#' @rdname SurvivalQuantities-class
68		SurvivalQuantities <- function(
69		object,
70		grid,
71		type = c("surv", "haz", "loghaz", "cumhaz")
72		) {
73	28x	type <- match.arg(type)
74	28x	assert_class(object, "JointModelSamples")
75	28x	assert_class(grid, "Grid")
76	26x	assert_that(
77	26x	!is(grid, "GridPopulation"),
78	26x	msg = "GridPopulation objects are not supported for `SurvivalQuantities`"
79		)
80
81	25x	time_grid <- seq(
82	25x	from = 0,
83	25x	to = max(as.list(object@data)[["event_times"]]),
84	25x	length = 201
85		)
86
87	25x	grid <- coalesceGridTime(grid, time_grid)
88
89	25x	generator <- as.QuantityGenerator(grid, data = object@data)
90
91	25x	assert_that(
92	25x	all(generator@times >= 0),
93	25x	msg = "Time points must be greater than or equal to 0"
94		)
95
96	23x	gq <- generateQuantities(
97	23x	object,
98	23x	generator = generator,
99	23x	type = "survival"
100		)
101
102	22x	quantities_raw <- extract_quantities(gq, type)
103	22x	collapser <- as.QuantityCollapser(grid, object@data)
104	22x	quantities <- collapse_quantities(quantities_raw, collapser)
105
106	22x	.SurvivalQuantities(
107	22x	quantities = Quantities(
108	22x	quantities,
109	22x	groups = collapser@groups,
110	22x	times = collapser@times
111		),
112	22x	grid = grid,
113	22x	data = object@data,
114	22x	type = type
115		)
116		}
117
118
119		#' `as.data.frame`
120		#'
121		#' @typed x: SurvivalQuantities
122		#' longitudinal quantities.
123		#' @param ... not used.
124		#' @family SurvivalQuantities
125		#' @export
126		as.data.frame.SurvivalQuantities <- function(x, ...) {
127	!	as.data.frame(x@quantities)
128		}
129
130
131		#' summary
132		#'
133		#' @description
134		#' This method returns a `data.frame` of the longitudinal quantities.
135		#'
136		#' @typed conf.level: numeric
137		#' confidence level of the interval.
138		#' @inheritParams SurvivalQuantities-Shared
139		#'
140		#' @family SurvivalQuantities
141		#' @family summary
142		#' @export
143		summary.SurvivalQuantities <- function(
144		object,
145		conf.level = 0.95,
146		...
147		) {
148	21x	summary(object@quantities, conf.level = conf.level)
149		}
150
151
152		#' Automatic Plotting for `SurvivalQuantities``
153		#'
154		#' @inheritParams SurvivalQuantities-Shared
155		#' @typed add_km: logical
156		#' if `TRUE` Kaplan-Meier curves will be added to the plot for
157		#' each group/subject.
158		#' @typed add_wrap: logical
159		#' if `TRUE` will apply a [ggplot2::facet_wrap()] to the plot
160		#' by each group/subject.
161		#' @typed conf.level: numeric
162		#' confidence level of the interval. If values of `FALSE`,
163		#' `NULL` or `0` are provided then confidence regions will not be added to the plot
164		#' @param ... not used.
165		#'
166		#' @family SurvivalQuantities
167		#' @family autoplot
168		#' @export
169		autoplot.SurvivalQuantities <- function(
170		object,
171		conf.level = 0.95,
172		add_km = FALSE,
173		add_wrap = TRUE,
174		...
175		) {
176	3x	include_ci <- !is.null(conf.level) &&
177	3x	is.numeric(conf.level) &&
178	3x	conf.level > 0
179		# If CI aren't needed supply a default 0.95 to summary function as it needs
180		# a value to be specified to work
181	3x	conf.level <- if (include_ci) conf.level else 0.95
182	3x	assert_that(
183	3x	is.flag(add_km),
184	3x	length(conf.level) == 1,
185	3x	conf.level < 1,
186	3x	is.flag(add_wrap)
187		)
188	3x	kmdf <- if (add_km) {
189	1x	subset(
190	1x	object@data,
191	1x	as.list(object@grid, data = object@data)
192		)
193		} else {
194	2x	NULL
195		}
196	3x	all_fit_df <- summary(object, conf.level = conf.level)
197	3x	label <- switch(
198	3x	object@type,
199	3x	"surv" = expression(S(t)),
200	3x	"cumhaz" = expression(H(t)),
201	3x	"haz" = expression(h(t)),
202	3x	"loghaz" = expression(log(h(t)))
203		)
204	3x	survival_plot(
205	3x	data = all_fit_df,
206	3x	add_ci = include_ci,
207	3x	add_wrap = add_wrap,
208	3x	kmdf = kmdf,
209	3x	y_label = label
210		)
211		}
212
213
214		#' Survival Plot
215		#'
216		#' Internal plotting function to create survival plots with KM curve overlays
217		#' This function predominately exists to extract core logic into its own function
218		#' to enable easier unit testing.
219		#'
220		#' @typed data: data.frame
221		#' summary statistics for a survival
222		#' curve to be plotted. See details.
223		#' @typed add_ci: logical
224		#' should confidence intervals be added? Default = `TRUE`.
225		#' @typed add_wrap: logical
226		#' should the plots be wrapped by `data$group`? Default = `TRUE`.
227		#' @typed kmdf: "`data.frame` or `NULL`"
228		#' event times and status used to plot
229		#' overlaying KM curves. If `NULL` no KM curve will be plotted. See details.
230		#' @typed y_label: "`character` or `expression`"
231		#' label to display on the y-axis.
232		#' Default = `expression(S(t))`.
233		#' @typed x_label: "`character` or `expression`"
234		#' label to display on the x-axis.
235		#'
236		#' @details
237		#'
238		#' ## `data`
239		#' Should contain the following columns:
240		#' - `time` (`numeric`) \cr time point for the summary statistic.
241		#' - `group` (`character`) \cr the group in which the observation belongs to.
242		#' - `median` (`numeric`) \cr the median value for the summary statistic.
243		#' - `upper` (`numeric`) \cr the upper 95% CI for the summary statistic.
244		#' - `lower` (`numeric`) \cr the lower 95% CI for the summary statistic.
245		#'
246		#' ## `kmdf`
247		#' Should contain the following columns:
248		#' - `time` (`numeric`) \cr the time at which an event occurred.
249		#' - `event` (`numeric`) \cr 1/0 status indicator for the event.
250		#' - `group` (`character`) \cr which group the event belongs to, should correspond to values in `data$group`.
251		#' @keywords internal
252		survival_plot <- function(
253		data,
254		add_ci = TRUE,
255		add_wrap = TRUE,
256		kmdf = NULL,
257		y_label = expression(S(t)),
258		x_label = expression(t)
259		) {
260	6x	assert_that(
261	6x	is.flag(add_ci),
262	6x	is.flag(add_wrap),
263	6x	is.expression(y_label) \|\| is.character(y_label),
264	6x	is.expression(x_label) \|\| is.character(x_label),
265	6x	is.null(kmdf) \| is.data.frame(kmdf)
266		)
267
268	6x	p <- ggplot() +
269	6x	xlab(x_label) +
270	6x	ylab(y_label) +
271	6x	theme_bw()
272
273	6x	if (add_wrap) {
274	2x	p <- p + facet_wrap(~group)
275	2x	aes_ci <- aes(x = .data$time, ymin = .data$lower, ymax = .data$upper)
276	2x	aes_line <- aes(x = .data$time, y = .data$median)
277	2x	aes_km <- aes(time = .data$time, status = .data$event)
278		} else {
279	4x	aes_ci <- aes(
280	4x	x = .data$time,
281	4x	ymin = .data$lower,
282	4x	ymax = .data$upper,
283	4x	fill = .data$group,
284	4x	group = .data$group
285		)
286	4x	aes_line <- aes(
287	4x	x = .data$time,
288	4x	y = .data$median,
289	4x	colour = .data$group,
290	4x	group = .data$group
291		)
292	4x	aes_km <- aes(
293	4x	time = .data$time,
294	4x	status = .data$event,
295	4x	group = .data$group,
296	4x	colour = .data$group
297		)
298		}
299	6x	p <- p + geom_line(aes_line, data = data)
300	6x	if (add_ci) {
301	2x	p <- p + geom_ribbon(aes_ci, data = data, alpha = 0.3)
302		}
303	6x	if (!is.null(kmdf)) {
304	2x	p <- p +
305	2x	ggplot2.utils::geom_km(aes_km, data = kmdf) +
306	2x	ggplot2.utils::geom_km_ticks(aes_km, data = kmdf)
307		}
308	6x	p
309		}
310
311
312		#' @rdname show-object
313		#' @export
314		setMethod(
315		f = "show",
316		signature = "SurvivalQuantities",
317		definition = function(object) {
318	2x	template <- c(
319	2x	"SurvivalQuantities Object:",
320	2x	" # of samples = %d",
321	2x	" # of quantities = %d",
322	2x	" Type = %s"
323		)
324	2x	string <- sprintf(
325	2x	paste(template, collapse = "\n"),
326	2x	nrow(object@quantities),
327	2x	ncol(object@quantities),
328	2x	object@type
329		)
330	2x	cat("\n", string, "\n\n")
331		}
332		)
333
334
335		#' `brierScore`
336		#'
337		#' @description
338		#' Derives the Brier Scores (using Inverse Probability of Censoring Weighting)
339		#' for the Survival estimates as detailed in \insertCite{blanche2015}{jmpost}.
340		#'
341		#' @inheritParams SurvivalQuantities-Shared
342		#' @inheritParams Brier-Score-Shared
343		#'
344		#' @family brierScore
345		#' @family SurvivalQuantities
346		#' @references
347		#' \insertAllCited{}
348		#' @export
349		brierScore.SurvivalQuantities <- function(
350		object,
351		maintain_cen_order = TRUE,
352		event_offset = TRUE,
353		...
354		) {
355	3x	assert_that(
356	3x	object@type == "surv",
357	3x	msg = paste(
358	3x	"Brier Score can only be calculated when the survival quantities were",
359	3x	"generated with `type = 'surv'`",
360	3x	collapse = " "
361		)
362		)
363	3x	assert_that(
364	3x	is(object@grid, "GridFixed"),
365	3x	msg = paste(
366	3x	"Brier Score can only be calculated when the survival quantities were",
367	3x	"generated with `grid = GridFixed()`",
368	3x	collapse = " "
369		)
370		)
371
372	3x	sdat <- summary(object)
373	3x	times <- unique(as.QuantityGenerator(object@grid, object@data)@times)
374	3x	times <- times[order(times)]
375	3x	assert_that(
376	3x	nrow(sdat) == length(times) * length(unique(sdat$group))
377		)
378
379	3x	subject_col <- extractVariableNames(object@data@subject)$subject
380	3x	time_col <- extractVariableNames(object@data@survival)$time
381	3x	event_col <- extractVariableNames(object@data@survival)$event
382	3x	groups <- as.character(object@data@survival@data[[subject_col]])
383	3x	orig_times <- object@data@survival@data[[time_col]]
384	3x	events <- as.numeric(object@data@survival@data[[event_col]])
385
386	3x	pred_mat <- matrix(
387	3x	ncol = length(times),
388	3x	nrow = length(unique(sdat$group))
389		)
390	3x	for (i in seq_along(times)) {
391	18x	pred_mat[, i] <- sdat[sdat["time"] == times[i], "median"]
392	18x	assert_that(
393	18x	all(groups == sdat[sdat["time"] == times[i], "group"])
394		)
395		}
396	3x	brier_score(
397	3x	t = times,
398	3x	times = orig_times,
399	3x	events = events,
400	3x	pred_mat = 1 - pred_mat,
401	3x	maintain_cen_order = maintain_cen_order,
402	3x	event_offset = event_offset
403		)
404		}

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		#' @slot scaled_variance logical scalar, whether the variance should be scaled
12		#' by the expected value, corresponding to a multiplicative model. If not,
13		#' then an additive error model is used.
14		#'
15		#' @exportClass LongitudinalModel
16		.LongitudinalModel <- setClass(
17		Class = "LongitudinalModel",
18		contains = "StanModel",
19		slots = c(
20		scaled_variance = "logical"
21		)
22		)
23
24		# LongitudinalModel-constructors ----
25
26		#' @rdname LongitudinalModel-class
27		#'
28		#' @inheritParams stanmodel_arguments
29		#' @typed scaled_variance: flag
30		#' whether the variance should be scaled
31		#' by the expected value, corresponding to a multiplicative model. If not,
32		#' then an additive error model is used.
33		#'
34		#' @export
35		LongitudinalModel <- function(
36		stan = StanModule(),
37		parameters = ParameterList(),
38		name = "<Unnamed>",
39		scaled_variance = NA,
40		...
41		) {
42	99x	assert_flag(scaled_variance)
43	99x	base_stan <- read_stan("base/longitudinal.stan")
44
45	99x	stan_full <- decorated_render(
46	99x	.x = base_stan,
47	99x	stan = add_missing_stan_blocks(as.list(stan))
48		)
49
50	99x	.LongitudinalModel(
51	99x	StanModel(
52	99x	stan = StanModule(stan_full),
53	99x	parameters = parameters,
54	99x	name = name,
55		...
56		),
57	99x	scaled_variance = scaled_variance
58		)
59		}
60
61		#' @export
62		as_print_string.LongitudinalModel <- function(object, ...) {
63	12x	string <- sprintf(
64	12x	"\n%s Longitudinal Model (%s error) with parameters:\n%s\n\n",
65	12x	object@name,
66	12x	if (is.na(object@scaled_variance)) {
67		# Should not happen but just to be robust against this case.
68	!	"unknown"
69	12x	} else if (object@scaled_variance) {
70	!	"multiplicative"
71		} else {
72	12x	"additive"
73		},
74	12x	paste(" ", as_print_string(object@parameters)) \|>
75	12x	paste(collapse = "\n")
76		)
77	12x	return(string)
78		}

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	73x	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	18x	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	2410x	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	243x	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	1904x	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	90690x	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	164x	UseMethod("size")
166		}
167
168
169		# auxiliaryInitialValues ----
170
171		#' `auxiliaryInitialValues`
172		#'
173		#' Obtain initial values for any additional Stan parameters introduced by an object.
174		#'
175		#' @param object where to get the auxiliary initial values from.
176		#' @param ... additional options.
177		#'
178		#' @details
179		#' Some objects, such as shrinkage priors, declare additional Stan parameters
180		#' beyond the main model parameter. This helper returns named initial values for
181		#' those additional parameters.
182		#'
183		#' @keywords internal
184		auxiliaryInitialValues <- function(object, ...) {
185	9927x	UseMethod("auxiliaryInitialValues")
186		}
187
188
189		# auxiliarySize ----
190
191		#' `auxiliarySize`
192		#'
193		#' Obtain sizes for any additional Stan parameters introduced by an object.
194		#'
195		#' @param object where to get the auxiliary parameter sizes from.
196		#' @param ... additional options.
197		#'
198		#' @details
199		#' Some objects, such as shrinkage priors, declare additional Stan parameters
200		#' beyond the main model parameter. This helper returns named sizes for those
201		#' additional parameters so their initial values can be expanded consistently.
202		#'
203		#' @keywords internal
204		auxiliarySize <- function(object, ...) {
205	138x	UseMethod("auxiliarySize")
206		}
207
208
209		# generateQuantities ----
210
211		#' `generateQuantities`
212		#'
213		#' Obtain the generated quantities from a Stan Model.
214		#'
215		#' @param object object to obtain generated quantities from
216		#' @param ... additional options.
217		#'
218		#' @export
219		generateQuantities <- function(object, ...) {
220	37x	UseMethod("generateQuantities")
221		}
222
223
224		#' Prepare Data Object
225		#'
226		#' @typed object: "`DataSubject` or `DataLongitudinal` or `DataSurvival`"
227		#' data object to "harmonise"
228		#' @typed subject_var: character
229		#' the name of the variable containing the subject identifier.
230		#' @typed subject_ord: character
231		#' the expected levels (in order) of the subject identifier.
232		#' @param ... not used.
233		#'
234		#' @details
235		#' This utility function prepares the datasets in the data objects in order to ensure they
236		#' are consistent and compatible with each other.
237		#'
238		#' In particular it ensures that the `subject` variable, as specified by `DataSubject`,
239		#' is available in `DataLongitudinal` and `DataSurvival` and that all levels are present
240		#' in all 3 data objects.
241		#'
242		#' It also sorts the datasets to ensure that indexes are consistent e.g. index 1 for
243		#' `DataSubject@data` corresponds to the same subject as index 1 for `DataSurvival@data`.
244		#' For `DataLongitudinal` the data is additionally sorted by time and outcome value.
245		#'
246		#' @seealso [`DataJoint`], [`DataSurvival`], [`DataSubject`], [`DataLongitudinal`]
247		#'
248		#' @keywords internal
249		#' @return Returns the original object but with the data standardised (see details)
250		harmonise <- function(object, ...) {
251	432x	UseMethod("harmonise")
252		}
253
254
255		#' @rdname harmonise
256		harmonise.default <- function(object, ...) {
257	14x	NULL
258		}
259
260
261		#' `as_stan_list`
262		#'
263		#' @description
264		#' Extracts a list of data elements from an object to be used as input
265		#' to a Stan Model
266		#'
267		#' @param object to be converted.
268		#' @param ... additional options.
269		#'
270		#' @family as_stan_list
271		#' @export
272		as_stan_list <- function(object, ...) {
273	2326x	UseMethod("as_stan_list")
274		}
275
276		#' @rdname as_stan_list
277		#' @export
278		as_stan_list.default <- function(object, ...) {
279	32x	NULL
280		}
281
282
283		#' `as_print_string`
284		#'
285		#' @description
286		#' Returns the character representation of an object which is suitable
287		#' for printing to the console
288		#'
289		#' @param object to be converted to string.
290		#' @param ... additional options.
291		#'
292		#' @family as_print_string
293		#' @keywords internal
294		as_print_string <- function(object, ...) {
295	135x	UseMethod("as_print_string")
296		}
297
298		#' Show an Object
299		#'
300		#' Prints an object to the console.
301		#'
302		#' @param object Object to be printed
303		#'
304		#' @name show-object
305		NULL
306
307
308		#' `brierScore`
309		#'
310		#' @description
311		#' Returns the Brier Score for a given model
312		#'
313		#' @param object to calculate Brier Score for.
314		#' @param ... additional options.
315		#'
316		#' @family brierScore
317		#' @export
318		brierScore <- function(object, ...) {
319	3x	UseMethod("brierScore")
320		}
321
322
323		#' Generate Simulated Observations
324		#'
325		#' @typed object: "`SimLongitudinal` or `SimSurvival`"
326		#' object to generate observations from.
327		#' @typed times_df: data.frame
328		#' the times at which to generate observations. See details.
329		#'
330		#' @details
331		#' The `times_df` argument should be a `data.frame` as created by `sampleSubjects` but
332		#' replicated for each time point at which observations are to be generated. That is if you want
333		#' to generate observations for times `c(0, 1, 2, 3)` then `times_df` should be created as:
334		#' ```
335		#' subject_dat <- sampleSubjects(object, ...)
336		#' times_df <- tidyr::expand_grid(
337		#' subject_dat,
338		#' time = c(0, 1, 2, 3)
339		#' )
340		#' ```
341		#'
342		#' @export
343		sampleObservations <- function(object, times_df) {
344	76x	UseMethod("sampleObservations")
345		}
346
347
348		#' Generate Simulated Subjects
349		#'
350		#' @typed object: "`SimLongitudinal` or `SimSurvival`"
351		#' object to generate subjects from.
352		#' @typed subjects_df: data.frame
353		#' the subjects to generate observations for. See details.
354		#'
355		#' @details
356		#' The `subjects_df` argument should be a `data.frame` with 1 row per desired subject to create
357		#' with the following columns:
358		#' - `study` (`factor`) the study identifier.
359		#' - `arm` (`factor`) the treatment arm identifier.
360		#' - `subject` (`character`) the subject identifier.
361		#'
362		#' This method takes care of generating all the individual subject data required for the
363		#' [`sampleObservations`] method to generate the observations.
364		#' @export
365		sampleSubjects <- function(object, subjects_df) {
366	52x	UseMethod("sampleSubjects")
367		}
368
369
370		#' Generate time windows for evaluating a hazard function
371		#'
372		#' @typed object: SurvivalModel
373		#' object to generate time windows for.
374		#' @param ... Not used.
375		#'
376		hazardWindows <- function(object, ...) {
377	24x	UseMethod("hazardWindows")
378		}
379
380		#' @rdname Quant-Dev
381		#' @export
382		as.QuantityGenerator <- function(object, ...) {
383	112x	UseMethod("as.QuantityGenerator")
384		}
385
386		#' @rdname Quant-Dev
387		#' @export
388		as.QuantityCollapser <- function(object, ...) {
389	43x	UseMethod("as.QuantityCollapser")
390		}
391
392
393		#' Coalesce Time
394		#'
395		#' @typed object: Grid
396		#' object to coalesce time for.
397		#' @typed times: numeric
398		#' the times to coalesce to.
399		#' @param ... Not used
400		#'
401		#' Method used to replace NULL times on grid objects (if appropriate)
402		#'
403		#' @keywords internal
404		coalesceGridTime <- function(object, times, ...) {
405	43x	UseMethod("coalesceGridTime")
406		}
407		#' @export
408		coalesceGridTime.default <- function(object, times, ...) {
409	5x	object
410		}
411
412
413		#' Resolve a Promise
414		#'
415		#' @typed object: ANY
416		#' an object to resolve.
417		#' @typed ...: ANY
418		#' additional arguments.
419		#'
420		#' If `object` is not a promise will just return itself else will resolve the promise
421		#' and return the promised object.
422		#'
423		#' @export
424		resolvePromise <- function(object, ...) {
425	118x	UseMethod("resolvePromise")
426		}
427
428		#' @rdname resolvePromise
429		#' @export
430		resolvePromise.default <- function(object, ...) {
431	!	object
432		}
433
434		#' Enable Link Generic
435		#'
436		#' @typed object: LongitudinalModel
437		#' to enable link for.
438		#' @param ... Not used.
439		#'
440		#' Optional hook method that is called on a [`LongitudinalModel`] only if a link method
441		#' is provided to [`JointModel`]. This can be used to allow the model to include any
442		#' optional stan code that is only required if there are links present.
443		#'
444		#' @return [`LongitudinalModel`] object
445		#'
446		#' @export
447		enableLink <- function(object, ...) {
448	24x	UseMethod("enableLink")
449		}
450		#' @export
451		enableLink.default <- function(object, ...) {
452	!	object
453		}
454
455
456		#' Enable Generated Quantities Generic
457		#'
458		#' @typed object: StanModel
459		#' to enable generated quantities for.
460		#' @param ... Not used.
461		#'
462		#' Optional hook method that is called on a [`StanModel`] if attempting to use
463		#' either [`LongitudinalQuantities`] or [`SurvivalQuantities`]
464		#'
465		#' @return [`StanModule`] object
466		#'
467		#' @export
468		enableGQ <- function(object, ...) {
469	132x	UseMethod("enableGQ")
470		}
471		#' @export
472		enableGQ.default <- function(object, ...) {
473	46x	StanModule()
474		}
475
476
477		#' Get Prediction Names
478		#'
479		#' Utility function that returns the names of the required parameters for predicting
480		#' survival quantities with [`GridPrediction`].
481		#'
482		#' @typed object: LongitudinalModel
483		#' A longitudinal model object
484		#' @param ... Not used.
485		#' @export
486		getPredictionNames <- function(object, ...) {
487	6x	UseMethod("getPredictionNames")
488		}
489
490		#' @rdname getPredictionNames
491		#' @export
492		getPredictionNames.default <- function(object, ...) {
493	1x	NULL
494		}
495
496
497		#' Get Random Effects Names
498		#'
499		#' Utility function that returns the names of the random effects parameters.
500		#' The main use for this is to allow the [`LongitudinalRandomEffects`] function
501		#' to know which parameters it needs to extract and to what common names
502		#' it should map the parameters to.
503		#'
504		#' @typed object: LongitudinalModel
505		#' A longitudinal model object
506		#' @param ... Not used.
507		#' @export
508		getRandomEffectsNames <- function(object, ...) {
509	2x	UseMethod("getRandomEffectsNames")
510		}
511
512		#' @rdname getRandomEffectsNames
513		#' @export
514		getRandomEffectsNames.default <- function(object, ...) {
515	!	NULL
516		}
517
518
519		#' As Formula
520		#'
521		#' Utility wrapper function to convert an object to a formula.
522		#' @typed x: ANY
523		#' object to convert to a formula.
524		#' @param ... Not used.
525		#' @export
526		as_formula <- function(x, ...) {
527	7x	UseMethod("as_formula")
528		}
529
530		#' @importFrom stats as.formula
531		#' @export
532		as_formula.default <- function(x, ...) {
533	!	as.formula(x, ...)
534		}
535
536
537		#' Set Constraints
538		#'
539		#' Applies constraints to a prior distribution to ensure any sampled numbers
540		#' from the distribution fall within the constraints
541		#'
542		#' @typed object: Prior
543		#' a prior distribution to apply constraints to
544		#' @typed lower: numeric
545		#' lower constraint boundary
546		#' @typed upper: numeric
547		#' upper constraint boundary
548		#'
549		#' @export
550		set_limits <- function(object, lower = -Inf, upper = Inf) {
551	533x	UseMethod("set_limits")
552		}
553
554
555		#' Save Object to File
556		#'
557		#' @typed object: ANY
558		#' object to save.
559		#' @typed file: character
560		#' file to save object to.
561		#' @typed ...: ANY
562		#' additional arguments.
563		#'
564		#' @family saveObject
565		#' @export
566		saveObject <- function(object, file, ...) {
567	1x	UseMethod("saveObject")
568		}
569
570
571		#' Extract Covariate Names
572		#'
573		#' @typed object: ANY
574		#' the object to extract covariate names from.
575		#' @param ... additional arguments added by methods.
576		#'
577		#' @family covariates
578		#' @export
579		covariates <- function(object, ...) {
580	2x	UseMethod("covariates")
581		}
582
583		#' Extract Covariate Shrinkage Factors from the Posterior Samples
584		#'
585		#' @typed object: ANY
586		#' the object to extract shrinkage factors from.
587		#' @param ... additional arguments added by methods.
588		#'
589		#' @family shrinkage
590		#' @export
591		shrinkage <- function(object, ...) {
592	1x	UseMethod("shrinkage")
593		}

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	62x	base_stan <- read_stan("base/survival.stan")
31	62x	stan_full <- decorated_render(
32	62x	.x = base_stan,
33	62x	stan = add_missing_stan_blocks(as.list(stan))
34		)
35	62x	.SurvivalModel(
36	62x	StanModel(
37	62x	name = name,
38	62x	stan = StanModule(stan_full),
39	62x	parameters = parameters,
40		...
41		)
42		)
43		}
44
45		#' @export
46		as_print_string.SurvivalModel <- function(object, ...) {
47	15x	string <- sprintf(
48	15x	"\n%s Survival Model with parameters:\n%s\n\n",
49	15x	object@name,
50	15x	paste(" ", as_print_string(object@parameters)) \|>
51	15x	paste(collapse = "\n")
52		)
53	15x	return(string)
54		}

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		#' @typed object: SimJointData
194		#' where the PFS events should be added.
195		#' @typed relative_threshold: number
196		#' a multiplicative threshold for the change in SLD compared to the `min(SLD)`.
197		#' Default is 1.2 meaning a 20% increase.
198		#' @typed absolute_threshold: number
199		#' an absolute threshold for the change in SLD compared to the minimum.
200		#' Default is 5.
201		#' @typed from_time: number
202		#' Ignore observations before this time for determining SLD minimum.
203		#' @typed observed_after: logical
204		#' If `FALSE` set longitudinal observations after the progression time to
205		#' `observed = FALSE`
206		#' @details
207		#' Both thresholds must be met for a progression to be declared.
208		#'
209		#' @export
210		#' @examples
211		#' data <- SimJointData(
212		#' survival = SimSurvivalExponential(lambda = 1/10),
213		#' longitudinal = SimLongitudinalSteinFojo()
214		#' )
215		#' data <- add_pfs(data)
216		#' data@survival # now has pfs_time and pfs_event columns
217		add_pfs <- function(
218		object,
219		relative_threshold = 1.2,
220		absolute_threshold = 5,
221		from_time = 0,
222		observed_after = FALSE
223		) {
224	3x	assert_class(object, "SimJointData")
225
226	3x	pd_times <- object@longitudinal \|>
227	3x	dplyr::filter(.data$time >= from_time) \|>
228	3x	dplyr::mutate(
229	3x	min_sld = cummin(.data$sld),
230	3x	is_pd = .data$sld >=
231	3x	pmax(
232	3x	.data$min_sld * relative_threshold,
233	3x	.data$min_sld + absolute_threshold
234		) &
235	3x	.data$observed,
236	3x	pd_time = min(.data$time[.data$is_pd], Inf),
237	3x	.by = "subject"
238		) \|>
239	3x	dplyr::select("subject", "pd_time") \|>
240	3x	dplyr::slice_head(by = "subject")
241
242	3x	if (isFALSE(observed_after)) {
243	2x	object@longitudinal <- object@longitudinal \|>
244	2x	dplyr::left_join(pd_times, by = "subject") \|>
245	2x	dplyr::mutate(
246	2x	observed = dplyr::if_else(
247	2x	.data$time > .data$pd_time,
248	2x	FALSE,
249	2x	.data$observed
250		),
251	2x	pd_time = NULL
252		)
253		}
254
255	3x	object@survival <-
256	3x	object@survival \|>
257	3x	dplyr::left_join(pd_times, by = "subject") \|>
258	3x	dplyr::mutate(
259	3x	pfs_time = pmin(.data$time, .data$pd_time, na.rm = TRUE),
260	3x	pfs_event = dplyr::if_else(
261	3x	.data$pfs_time < .data$time,
262	3x	1,
263	3x	.data$event
264		),
265	3x	pd_time = NULL
266		)
267	3x	object
268		}
269
270
271		#' Cut Study Data
272		#' @typed object: SimJointData
273		#' where the cut times should be applied.
274		#' @typed cut_time: numeric
275		#' A vector of cut off times, either length 1 for all patients or
276		#' `nrow(object@survival)` for a time per patient.
277		#' @details
278		#' All observations after this time are remove. Survival is censored at this time and any longitudinal
279		#' values are removed.
280		#' @export
281		#' @examples
282		#' data <- SimJointData(
283		#' survival = SimSurvivalExponential(lambda = 1/10),
284		#' longitudinal = SimLongitudinalSteinFojo()
285		#' )
286		#' data <- cut_data(data, 5)
287		#' data@survival
288		#' # Now max time is 5
289		#' max(data@survival$time)
290		cut_data <- function(object, cut_time) {
291	3x	assert_class(object, "SimJointData")
292	3x	check_len <- if (length(cut_time) > 1) nrow(object@survival) else 1
293	3x	assert_numeric(cut_time, lower = 0, len = check_len)
294
295	2x	object@survival <- object@survival \|>
296	2x	dplyr::mutate(
297	2x	cut_time = cut_time,
298	2x	event = dplyr::if_else(.data$time < .data$cut_time, .data$event, 0),
299	2x	time = pmin(.data$cut_time, .data$time)
300		)
301	2x	if (all(c("pfs_event", "pfs_time") %in% colnames(object@survival))) {
302	!	object@survival <- object@survival \|>
303	!	dplyr::mutate(
304	!	pfs_event = dplyr::if_else(
305	!	.data$pfs_time < .data$cut_time,
306	!	.data$pfs_event,
307	!	0
308		),
309	!	pfs_time = pmin(.data$cut_time, .data$pfs_time)
310		)
311		}
312
313	2x	object@longitudinal <- object@longitudinal \|>
314	2x	dplyr::left_join(
315	2x	dplyr::select(object@survival, "subject", "cut_time"),
316	2x	by = "subject"
317		) \|>
318	2x	dplyr::filter(.data$time <= .data$cut_time) \|>
319	2x	dplyr::mutate(cut_time = NULL)
320
321	2x	object@survival$cut_time <- NULL
322
323	2x	object
324		}

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

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	18x	sizes <- vapply(
112	18x	cmdstanr::as.CmdStanMCMC(object)$metadata()[["stan_variable_sizes"]],
113	18x	\(x) {
114	280x	if (length(x) == 1 && x == 1) {
115	88x	return("")
116		}
117	192x	paste0("[", paste(x, collapse = ", "), "]")
118		},
119	18x	character(1)
120		)
121	18x	variable_string <- paste0(
122		" ",
123	18x	cmdstanr::as.CmdStanMCMC(object)$metadata()[["stan_variables"]],
124	18x	sizes
125		)
126	18x	template <- c(
127	18x	"JointModelSamples Object with:",
128		"",
129	18x	" # of samples per chain = %d",
130	18x	" # of chains = %d",
131		"",
132	18x	" Variables:",
133	18x	variable_string[order(variable_string)]
134		)
135	18x	pad <- rep(" ", indent) \|> paste(collapse = "")
136	18x	template_padded <- paste(pad, template)
137	18x	sprintf(
138	18x	paste(template_padded, collapse = "\n"),
139	18x	cmdstanr::as.CmdStanMCMC(object)$metadata()$iter_sampling,
140	18x	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	18x	string <- as_print_string(object)
151	18x	cat("\n", string, "\n\n")
152		}
153		)
154
155
156		#' @rdname as.CmdStanMCMC
157		as.CmdStanMCMC.JointModelSamples <- function(object, ...) {
158	84x	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		}
186
187		#' Extract shrinkage factors from a `JointModelSamples` object
188		#'
189		#' @typed object: JointModelSamples
190		#' the object to extract shrinkage factors from.
191		#' @param ... not used.
192		#' @return the shrinkage factors correctly named after the covariate names.
193		#'
194		#' @family shrinkage
195		#' @export
196		shrinkage.JointModelSamples <- function(object, ...) {
197	1x	draws <- cmdstanr::as.CmdStanMCMC(object)$draws()
198	1x	assert_class(object@data@survival, "DataSurvival")
199	1x	covariate_names <- covariates(object@data@survival)
200	1x	assert_subset(
201	1x	"prior_shrinkage_factors_beta_os_cov[1]",
202	1x	posterior::variables(draws)
203		)
204	1x	shrinkage_draws <- subset(
205	1x	draws,
206	1x	variable = "prior_shrinkage_factors_beta_os_cov"
207		)
208	1x	shrinkage_vars <- posterior::variables(shrinkage_draws)
209	1x	assert_true(identical(length(covariate_names), length(shrinkage_vars)))
210	1x	posterior::variables(shrinkage_draws) <- covariate_names
211	1x	shrinkage_draws
212		}

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	25x	lambda <- set_limits(lambda, lower = getOption("jmpost.double_eps"))
32	25x	.SurvivalExponential(
33	25x	SurvivalModel(
34	25x	name = "Exponential",
35	25x	stan = StanModule("sm-exponential/model.stan"),
36	25x	parameters = ParameterList(
37	25x	Parameter(name = "sm_exp_lambda", prior = lambda, size = 1),
38	25x	Parameter(
39	25x	name = "beta_os_cov",
40	25x	prior = beta,
41	25x	size = "p_os_cov_design"
42		)
43		)
44		)
45		)
46		}

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	52x	.DataSurvival(
48	52x	data = remove_missing_rows(data, formula),
49	52x	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	404x	list(
95	404x	frm = object@formula,
96	404x	time = as.character(object@formula[[2]][[2]]),
97	404x	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	397x	x <- x@data
113	397x	rownames(x) <- NULL
114	397x	x
115		}
116
117
118		#' @rdname as_stan_list.DataObject
119		#' @family DataSurvival
120		#' @param df (`data.frame`)\cr The data frame to be used for generating the design matrix.
121		#' @param vars (`list`)\cr The list of variable names to be used for generating the design matrix.
122		#' @export
123		model.matrix.DataSurvival <- function(
124		object,
125		df = as.data.frame(object),
126		vars = extractVariableNames(object),
127		...
128		) {
129	336x	design_mat <- stats::model.matrix(vars$frm, data = df)
130	336x	remove_index <- grep("(Intercept)", colnames(design_mat), fixed = TRUE)
131	336x	if (length(remove_index) > 0) {
132	334x	design_mat <- design_mat[, -remove_index, drop = FALSE]
133		}
134	336x	rownames(design_mat) <- NULL
135	336x	design_mat
136		}
137
138		#' Extract Covariate Names for Survival Data
139		#'
140		#' @typed object: DataSurvival
141		#' Survival data object to extract covariate names from.
142		#' @param ... not used.
143		#'
144		#' @family covariates
145		#' @export
146		covariates.DataSurvival <- function(object, ...) {
147	2x	design_mat <- model.matrix(object, ...)
148	2x	colnames(design_mat)
149		}
150
151		#' @rdname as_stan_list.DataObject
152		#' @family DataSurvival
153		#' @export
154		as_stan_list.DataSurvival <- function(object, ...) {
155	333x	df <- as.data.frame(object)
156	333x	vars <- extractVariableNames(object)
157
158	333x	design_mat <- model.matrix(object, df = df, vars = vars)
159
160		# Parameters for efficient integration of hazard function -> survival function
161	333x	gh_parameters <- statmod::gauss.quad(
162	333x	n = getOption("jmpost.gauss_quad_n"),
163	333x	kind = "legendre"
164		)
165
166	333x	model_data <- list(
167	333x	n_subject_event = sum(df[[vars$event]]),
168	333x	subject_event_index = which(df[[vars$event]] == 1),
169	333x	event_times = df[[vars$time]],
170	333x	p_os_cov_design = ncol(design_mat),
171	333x	os_cov_design = design_mat,
172	333x	n_nodes = length(gh_parameters$nodes),
173	333x	nodes = gh_parameters$nodes,
174	333x	weights = gh_parameters$weights
175		)
176	333x	return(model_data)
177		}
178
179		#' @rdname as_stan_list.DataObject
180		#' @export
181		as.list.DataSurvival <- function(x, ...) {
182	2x	as_stan_list(x, ...)
183		}
184
185		#' @rdname harmonise
186		#' @exportS3Method NULL
187		harmonise.DataSurvival <- function(object, subject_var, subject_ord, ...) {
188	23x	data <- as.data.frame(object)
189
190	23x	assert_string(subject_var, na.ok = FALSE)
191	23x	assert_character(subject_ord, any.missing = FALSE)
192	23x	assert_that(
193	23x	subject_var %in% names(data),
194	23x	msg = sprintf(
195	23x	"Subject variable `%s` not found in `survival`",
196	23x	subject_var
197		)
198		)
199	22x	assert_that(
200	22x	all(data[[subject_var]] %in% subject_ord),
201	22x	msg = "There are subjects in `survival` that are not present in `subjects`"
202		)
203	21x	assert_that(
204	21x	all(subject_ord %in% data[[subject_var]]),
205	21x	msg = "There are subjects in `subjects` that are not present in `survival`"
206		)
207
208	20x	data[[subject_var]] <- factor(
209	20x	as.character(data[[subject_var]]),
210	20x	levels = subject_ord
211		)
212
213	20x	data_ord <- data[order(data[[subject_var]]), ]
214
215	20x	DataSurvival(
216	20x	data = data_ord,
217	20x	formula = object@formula
218		)
219		}
220
221
222		#' `DataSurvival` -> Printable `Character`
223		#'
224		#' Converts [`DataSurvival`] object into a printable string.
225		#' @inheritParams DataSurvival-Shared
226		#' @family DataSurvival
227		#' @typed indent: numeric
228		#' how much white space to prefix the print string with.
229		#' @keywords internal
230		#' @export
231		as_print_string.DataSurvival <- function(object, indent = 1, ...) {
232	3x	template <- c(
233	3x	"Survival-Data Object:",
234	3x	" # of Rows = %d",
235	3x	" # of Columns = %d",
236	3x	" # of Events = %d",
237	3x	" Formula = %s"
238		)
239	3x	pad <- rep(" ", indent) \|> paste(collapse = "")
240	3x	template_padded <- paste(pad, template)
241	3x	vars <- extractVariableNames(object)
242	3x	sprintf(
243	3x	paste(template_padded, collapse = "\n"),
244	3x	nrow(object@data),
245	3x	ncol(object@data),
246	3x	sum(object@data[[vars$event]]),
247	3x	Reduce(paste, deparse(vars$frm))
248		)
249		}
250
251		#' @rdname show-object
252		#' @export
253		setMethod(
254		f = "show",
255		signature = "DataSurvival",
256		definition = function(object) {
257	1x	string <- as_print_string(object)
258	1x	cat("\n", string, "\n\n")
259		}
260		)
261
262		#' Build design matrix for prediction data
263		#'
264		#' @description
265		#' This function takes a `DataSurvival` object and a `data.frame` object and generates
266		#' a design matrix for the `data.frame` that has the identical structure to the
267		#' design matrix of the `DataSurvival` object.
268		#'
269		#' This is used for predicting new data using a model that was trained on a different
270		#' original data source
271		#'
272		#' @typed olddata: DataSurvival
273		#' The original data to be used as a template for the new data
274		#' @typed newdata: data.frame
275		#' The new data to be used to generate the design matrix
276		#' @importFrom stats .checkMFClasses terms delete.response model.frame model.matrix
277		#' @importFrom survival coxph
278		#' @keywords internal
279		mirror_design_matrix <- function(olddata, newdata) {
280	7x	frm <- as_formula(olddata)
281		# Dummy model to generate a bunch of meta information that we can use to
282		# re-construct the design matrix
283	7x	model <- coxph(data = as.data.frame(olddata), formula = frm)
284	7x	model_terms <- delete.response(terms(model))
285	7x	model_frame <- model.frame(
286	7x	model_terms,
287	7x	newdata,
288	7x	xlev = model$xlevels
289		)
290	4x	if (!is.null(data_classes <- attr(model_terms, "dataClasses"))) {
291	4x	.checkMFClasses(data_classes, model_frame)
292		}
293	3x	design_mat <- model.matrix(
294	3x	model_terms,
295	3x	model_frame,
296	3x	contrasts.arg = model$contrasts
297		)
298	3x	remove_index <- grep("(Intercept)", colnames(design_mat), fixed = TRUE)
299	3x	design_mat <- design_mat[, -remove_index, drop = FALSE]
300	3x	rownames(design_mat) <- NULL
301	3x	design_mat
302		}
303
304
305		#' @export
306		as_formula.DataSurvival <- function(x, ...) {
307	7x	vars <- extractVariableNames(x)
308	7x	vars$frm
309		}

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	404x	vars <- c(subject, arm, study)
51	404x	vars_frm_chr <- paste0("~ ", paste(vars, collapse = " + "))
52	404x	.DataSubject(
53	404x	data = remove_missing_rows(data, stats::as.formula(vars_frm_chr)),
54	404x	subject = subject,
55	404x	arm = arm,
56	404x	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	1106x	list(
97	1106x	subject = object@subject,
98	1106x	arm = object@arm,
99	1106x	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	335x	df <- as.data.frame(harmonise(object))
109	335x	vars <- extractVariableNames(object)
110
111	335x	unique_arm_study_combos <- unique(
112	335x	data.frame(
113	335x	arm = as.numeric(df[[vars$arm]]),
114	335x	study = as.numeric(df[[vars$study]])
115		)
116		)
117
118	335x	list(
119	335x	n_subjects = nrow(df),
120	335x	n_studies = length(unique(df[[vars$study]])),
121	335x	n_arms = length(unique(df[[vars$arm]])),
122	335x	subject_study_index = as.numeric(df[[vars$study]]),
123	335x	subject_arm_index = as.numeric(df[[vars$arm]]),
124	335x	subject_to_index = stats::setNames(
125	335x	seq_len(nlevels(df[[vars$subject]])),
126	335x	levels(df[[vars$subject]])
127		),
128	335x	arm_to_index = stats::setNames(
129	335x	seq_len(nlevels(df[[vars$arm]])),
130	335x	levels(df[[vars$arm]])
131		),
132	335x	study_to_index = stats::setNames(
133	335x	seq_len(nlevels(df[[vars$study]])),
134	335x	levels(df[[vars$study]])
135		),
136	335x	pop_arm_index = unique_arm_study_combos$arm,
137	335x	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	795x	x <- x@data
159	795x	rownames(x) <- NULL
160	795x	x
161		}
162
163
164		#' @rdname harmonise
165		#' @exportS3Method NULL
166		harmonise.DataSubject <- function(object, ...) {
167	369x	data <- as.data.frame(object)
168	369x	vars <- extractVariableNames(object)
169	369x	assert_that(
170	369x	vars$subject %in% names(data),
171	369x	vars$arm %in% names(data),
172	369x	vars$study %in% names(data)
173		)
174	369x	assert_character(
175	369x	as.character(data[[vars$subject]]),
176	369x	any.missing = FALSE,
177	369x	unique = TRUE
178		)
179	368x	data[[vars$subject]] <- factor(data[[vars$subject]])
180	368x	data[[vars$arm]] <- factor(data[[vars$arm]])
181	368x	data[[vars$study]] <- factor(data[[vars$study]])
182	368x	data <- data[order(data[[vars$subject]]), ]
183	368x	DataSubject(
184	368x	data = data,
185	368x	subject = object@subject,
186	368x	arm = object@arm,
187	368x	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 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. When converted to a [`StanModule`], the list supplies the
24		#' Stan declarations and prior statements for those parameters.
25		#'
26		#'
27
28		#' @slot parameters (`list`) \cr a list of [`Parameter`] objects
29		#' @family ParameterList
30		#' @export ParameterList
31		#' @exportClass ParameterList
32		.ParameterList <- setClass(
33		Class = "ParameterList",
34		slots = c(
35		parameters = "list"
36		)
37		)
38		#' @typed ...: Parameter
39		#' which parameter specifications to include.
40		#' @rdname ParameterList-class
41		ParameterList <- function(...) {
42	368x	.ParameterList(parameters = list(...))
43		}
44
45		# ParameterList-validity ----
46
47		setValidity(
48		Class = "ParameterList",
49		method = function(object) {
50		is_parameters <- vapply(
51		object@parameters,
52		function(x) is(x, "Parameter"),
53		logical(1)
54		)
55		if (!all(is_parameters)) {
56		return("all elements must be of class 'Parameter'")
57		}
58		return(TRUE)
59		}
60		)
61
62
63		# as.StanModule-ParameterList ----
64
65		#' `ParameterList` -> `StanModule`
66		#'
67		#' Converts a [`ParameterList`] object to a [`StanModule`] object
68		#'
69		#' @inheritParams ParameterList-Shared
70		#'
71		#' @family ParameterList
72		#' @family as.StanModule
73		#' @export
74		as.StanModule.ParameterList <- function(object, ...) {
75	105x	stan_modules <- lapply(
76	105x	object@parameters,
77	105x	as.StanModule
78		)
79	105x	assert_that(
80	105x	all(vapply(stan_modules, inherits, logical(1), "StanModule"))
81		)
82	105x	Reduce(merge, stan_modules)
83		}
84
85
86		#' `ParameterList` -> `list`
87		#'
88		#' Converts a ParameterList object to a list of parameter data values
89		#' for a Stan model.
90		#'
91		#' @inheritParams ParameterList-Shared
92		#'
93		#' @family as_stan_list
94		#' @family ParameterList
95		#' @export
96		as_stan_list.ParameterList <- function(object, ...) {
97	58x	stan_lists <- lapply(
98	58x	object@parameters,
99	58x	as_stan_list
100		)
101	58x	assert_that(
102	58x	all(vapply(stan_lists, is.list, logical(1)))
103		)
104	58x	Reduce(append, stan_lists)
105		}
106
107
108		# merge-ParameterList,ParameterList ----
109
110		#' @rdname merge
111		setMethod(
112		f = "merge",
113		signature = c(x = "ParameterList", y = "ParameterList"),
114		definition = function(x, y) {
115	82x	parameters <- append(x@parameters, y@parameters)
116	82x	do.call(ParameterList, parameters)
117		}
118		)
119
120		# as.list-ParameterList ----
121
122		#' `ParameterList` -> `list`
123		#' @description
124		#' Returns a named list where each element of the list corresponds
125		#' to a Stan modelling block e.g. `data`, `model`, etc.
126		#' @inheritParams ParameterList-Shared
127		#' @family ParameterList
128		#' @export
129		as.list.ParameterList <- function(x, ...) {
130	103x	as.list(as.StanModule(x))
131		}
132
133
134		#' Parameter-List Getter Functions
135		#' @description
136		#' Getter functions for the slots of a [`ParameterList`] object
137		#' @inheritParams ParameterList-Shared
138		#' @family ParameterList
139		#' @typed n_chains: integer
140		#' the number of chains.
141		#' @name ParameterList-Getter-Methods
142		NULL
143
144
145		#' @describeIn ParameterList-Getter-Methods The parameter-list's parameter names
146		#' @export
147		names.ParameterList <- function(x) {
148	125x	vapply(x@parameters, names, character(1))
149		}
150
151
152		#' @describeIn ParameterList-Getter-Methods The parameter-list's parameter initial values
153		#' @export
154		initialValues.ParameterList <- function(object, n_chains, ...) {
155	51x	parameters <- Filter(\(x) !x@prior@.is_const, object@parameters)
156		# Generate initial values as a list of lists. This is to ensure it is in the required
157		# format as specified by cmdstanr see the `init` argument of
158		# `help("model-method-sample", "cmdstanr")` for more details
159	51x	lapply(
160	51x	seq_len(n_chains),
161	51x	\(i) {
162	966x	vals <- lapply(parameters, function(parameter) {
163	9940x	c(
164	9940x	stats::setNames(
165	9940x	list(initialValues(parameter)),
166	9940x	names(parameter)
167		),
168	9940x	auxiliaryInitialValues(
169	9940x	parameter@prior,
170	9940x	name = names(parameter),
171	9940x	size = size(parameter)
172		)
173		)
174		})
175	951x	unlist(vals, recursive = FALSE)
176		}
177		)
178		}
179
180
181		#' @describeIn ParameterList-Getter-Methods The parameter-list's parameter dimensionality
182		#' @export
183		size.ParameterList <- function(object) {
184	20x	parameters <- Filter(\(x) !x@prior@.is_const, object@parameters)
185	20x	sizes <- lapply(parameters, function(parameter) {
186	136x	c(
187	136x	stats::setNames(list(size(parameter)), names(parameter)),
188	136x	auxiliarySize(
189	136x	parameter@prior,
190	136x	name = names(parameter),
191	136x	size = size(parameter)
192		)
193		)
194		})
195	20x	unlist(sizes, recursive = FALSE)
196		}
197
198
199		#' `ParameterList` -> Printable `Character`
200		#'
201		#' Converts [`ParameterList`] object into a printable string.
202		#' @inheritParams ParameterList-Shared
203		#' @family ParameterList
204		#' @keywords internal
205		#' @export
206		as_print_string.ParameterList <- function(object, ...) {
207	42x	x <- vapply(object@parameters, as.character, character(1))
208	42x	if (length(x) == 0) {
209	!	x <- "<No Parameters>"
210		}
211	42x	return(x)
212		}
213
214
215		#' @rdname show-object
216		#' @export
217		setMethod(
218		f = "show",
219		signature = "ParameterList",
220		definition = function(object) {
221	1x	chrs <- as_print_string(object)
222	1x	string <- paste(" ", chrs) \|> paste(collapse = "\n")
223	1x	x <- sprintf("\nParameterList Object:\n%s\n\n", string)
224	1x	cat(x)
225	1x	return(object)
226		}
227		)

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		#' 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		#' @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	a <- set_limits(a, lower = getOption("jmpost.double_eps"))
35	9x	b <- set_limits(b, lower = getOption("jmpost.double_eps"))
36
37	9x	.SurvivalLogLogistic(
38	9x	SurvivalModel(
39	9x	name = "Log-Logistic",
40	9x	stan = StanModule("sm-loglogistic/model.stan"),
41	9x	parameters = ParameterList(
42	9x	Parameter(name = "sm_loglogis_a", prior = a, size = 1),
43	9x	Parameter(name = "sm_loglogis_b", prior = b, size = 1),
44	9x	Parameter(
45	9x	name = "beta_os_cov",
46	9x	prior = beta,
47	9x	size = "p_os_cov_design"
48		)
49		)
50		)
51		)
52		}

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		#' `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		#' 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		#' ## `jmpost.double_eps` and `jmpost.double_neg_eps`
46		#'
47		#' Default = `0` and `sqrt(.Machine$double.neg.eps)`
48		#'
49		#' These are small floating-point numbers `x` which are used in parameter
50		#' definitions as lower boundaries to prevent numerical issues with the MCMC
51		#' sampler in the beginning of the sampling process.
52		#'
53		#' @examples
54		#' \dontrun{
55		#' options(jmpost.prior_shrinkage = 0.5)
56		#' }
57		#' @name jmpost-settings
58		set_options <- function() {
59	!	cache_dir <- Sys.getenv("JMPOST_CACHE_DIR")
60
61	!	if (cache_dir == "" \|\| is.null(cache_dir)) {
62	!	cache_dir <- tempfile()
63		}
64
65	!	current_opts <- names(options())
66	!	jmpost_opts <- list(
67	!	jmpost.cache_dir = cache_dir,
68	!	jmpost.prior_shrinkage = 0.5,
69	!	jmpost.gauss_quad_n = 15,
70	!	jmpost.double_eps = 0,
71	!	jmpost.double_neg_eps = sqrt(.Machine$double.neg.eps)
72		)
73	!	for (opt in names(jmpost_opts)) {
74	!	if (!opt %in% current_opts) {
75	!	options(jmpost_opts[opt])
76		}
77		}
78		}

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 SurvivalModel.R
2		NULL
3
4		# SurvivalWeibullPH-class ----
5
6		#' `SurvivalWeibullPH`
7		#'
8		#' This class extends the general [`SurvivalModel`] class for using the
9		#' Weibull proportional hazards survival model.
10		#'
11		#' @exportClass SurvivalWeibullPH
12		.SurvivalWeibullPH <- setClass(
13		Class = "SurvivalWeibullPH",
14		contains = "SurvivalModel"
15		)
16
17		# SurvivalWeibullPH-constructors ----
18
19		#' @rdname SurvivalWeibullPH-class
20		#'
21		#' @typed lambda: Prior
22		#' for the scale `lambda`.
23		#' @typed gamma: Prior
24		#' for the shape `gamma`.
25		#' @typed beta: Prior
26		#' for covariates coefficients `beta`.
27		#'
28		#' @export
29		SurvivalWeibullPH <- function(
30		lambda = prior_gamma(2, 0.5),
31		gamma = prior_gamma(2, 0.5),
32		beta = prior_normal(0, 2)
33		) {
34	24x	lambda <- set_limits(lambda, lower = getOption("jmpost.double_eps"))
35	24x	gamma <- set_limits(gamma, lower = getOption("jmpost.double_eps"))
36
37	24x	.SurvivalWeibullPH(
38	24x	SurvivalModel(
39	24x	name = "Weibull-PH",
40	24x	stan = StanModule(x = "sm-weibull-ph/model.stan"),
41	24x	parameters = ParameterList(
42	24x	Parameter(
43	24x	name = "sm_weibull_ph_lambda",
44	24x	prior = lambda,
45	24x	size = 1
46		),
47	24x	Parameter(
48	24x	name = "sm_weibull_ph_gamma",
49	24x	prior = gamma,
50	24x	size = 1
51		),
52	24x	Parameter(
53	24x	name = "beta_os_cov",
54	24x	prior = beta,
55	24x	size = "p_os_cov_design"
56		)
57		)
58		)
59		)
60		}

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	56x	.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	58x	.PromiseLinkComponent(
56	58x	fun = fun,
57	58x	stan = StanModule(),
58	58x	parameters = ParameterList(Parameter(
59	58x	name = key,
60	58x	prior = prior,
61	58x	size = 1
62		)),
63	58x	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	51x	x <- object@fun(
91	51x	prior = object@parameters@parameters[[1]]@prior,
92	51x	model = model
93		)
94	51x	assert_that(
95	51x	is(x, "LinkComponent"),
96	51x	msg = "Resolved `PromiseLinkComponent` did not produce a `LinkComponent` object"
97		)
98	51x	assert_that(
99	51x	names(object) == names(x),
100	51x	msg = paste(
101	51x	"Resolved `PromiseLinkComponent` did not produce a `LinkComponent` object",
102	51x	"with the same key as the promise"
103		)
104		)
105	50x	x
106		}

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		#' Define Simulation Group
2		#'
3		#' Specifies a simulation group to be used by [`SimJointData()`].
4		#'
5		#' @typed n: numeric
6		#' number of subjects in the group.
7		#' @typed arm: character
8		#' treatment arm.
9		#' @typed study: character
10		#' study name.
11		#'
12		#' @slot n (`numeric`)\cr See arguments.
13		#' @slot arm (`character`)\cr See arguments.
14		#' @slot study (`character`)\cr See arguments.
15		#'
16		#' @examples
17		#' SimGroup(n = 50, arm = "Arm-A", study = "Study-1")
18		#' @name SimGroup-class
19		#' @exportClass SimGroup
20		.SimGroup <- setClass(
21		"SimGroup",
22		slots = c(
23		n = "numeric",
24		arm = "character",
25		study = "character"
26		)
27		)
28
29		#' @export
30		#' @rdname SimGroup-class
31		SimGroup <- function(n, arm, study) {
32	56x	.SimGroup(
33	56x	n = n,
34	56x	arm = arm,
35	56x	study = study
36		)
37		}
38
39
40		setValidity(
41		"SimGroup",
42		function(object) {
43		if (length(object@n) != 1) {
44		return("`n` must be a length 1 integer")
45		}
46		if (length(object@arm) != 1) {
47		return("`arm` must be a length 1 string")
48		}
49		if (length(object@study) != 1) {
50		return("`study` must be a length 1 string")
51		}
52		if (any(object@n < 1) \| any(object@n %% 1 != 0)) {
53		return("`n` must be positive integer")
54		}
55		return(TRUE)
56		}
57		)

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 = getOption("jmpost.double_eps"))
34	4x	theta <- set_limits(theta, lower = getOption("jmpost.double_eps"))
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		}