#' @include DataSurvival.R

#' @include DataLongitudinal.R

#' @include DataSubject.R

NULL

#' Re-used documentation for `DataJoint`

#'

#' @param object ([`DataJoint`]) \cr Survival and Longitudinal Data.

#' @param x ([`DataJoint`]) \cr 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"

    )

)

#' @param subject (`DataSubject`)\cr object created by [DataSubject()].

#' @param survival (`DataSurvival`)\cr object created by [DataSurvival()].

#' @param longitudinal (`DataLongitudinal`)\cr object created by [DataLongitudinal()].

#' @rdname DataJoint-class

DataJoint <- function(subject, survival = NULL, longitudinal = NULL) {

    )

    )

    )

}

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`

#'

#' @param object (`DataSubject` or `DataLongitudinal` or `DataSurvival`) \cr

#' data object to convert to a `list`.

#' @param x (`DataSubject` or `DataLongitudinal` or `DataSurvival`) \cr

#' data object to convert to a `list`.

#' @param subject_var (`character`) \cr 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, ...) {

        ))

}

#' @rdname as_stan_list.DataObject

#' @export

as.list.DataJoint <- function(x, ...) {

}

#' Subsetting `DataJoint` as a `data.frame`

#'

#' @param x (`DataJoint`) \cr object created by [DataJoint()].

#' @param subjects (`character` or `list`)\cr 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, ...) {

    )

}

#' `subset_and_add_grouping`

#'

#' @param dat (`data.frame`) \cr must have a column called `subject` which corresponds to the

#' values passed to `groupings`.

#' @param groupings (`character` or `list`)\cr 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) {

        }

    )

}

#' Extract Observed Longitudinal Values

#'

#' Utility function to extract the observed longitudinal values from a [`DataJoint`] object

#' @param object ([`DataJoint`])\cr 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) {

    )

}

#' @rdname show-object

#' @export

setMethod(

    f = "show",

    signature = "DataJoint",

    definition = function(object) {

        } else {

        }

        } else {

        }

            "",

            "",

            "",

        )

    }

)

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

    )

}

#' @rdname Quant-Dev

#' @export

as.QuantityGenerator.GridPopulation <- function(object, data, ...) {

    )

}

#' @rdname Quant-Dev

#' @export

as.QuantityCollapser.GridPopulation <- function(object, data, ...) {

        ),

    )

}

#' @export

as.list.GridPopulation <- function(x, data, ...) {

}

#' @rdname coalesceGridTime

#' @export

coalesceGridTime.GridPopulation <- function(object, times, ...) {

        )

    }

}

#' Re-used documentation for Brier Score components

#'

#' @param t (`numeric`)\cr timepoints to calculate the desired quantity at.

#' @param times (`numeric`)\cr observed times.

#' @param events (`numeric`)\cr event indicator for `times`. Either 1 for an event or 0 for censor.

#' @param event_offset (`logical`)\cr 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.

#' @param maintain_cen_order (`logical`)\cr 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) {

    )

    )

}

#' @rdname reverse_km

reverse_km_cen_first <- function(t, times, events) {

    )

    )

    )

    )

    )

}

#' Match Order

#'

#' @param x (`numeric`)\cr 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) {

}

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

) {

    )

    )

    # 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

}

#' @rdname brier_score

bs_get_squared_dist <- function(t, times, events, pred_mat) {

    )

    )

    )

    )

    )

    ) |>

    )

}

#' @rdname brier_score

bs_get_weights <- function(

    t,

    times,

    events,

    event_offset = TRUE,

    maintain_cen_order = TRUE

) {

    )

    )

    )

    )

    )

    ) |>

    ) |>

    )

}

#' Row Numbers of Data with Missing Variables

#'

#' @param df (`data.frame`)\cr input data.

#' @param formula (`formula` or `NULL`)\cr 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) {

    }

}

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

#'

#' @param data (`data.frame`)\cr input data.

#' @param formula (`formula` or `NULL`)\cr which variables to inspect for missingness.

#' @param extra_vars (`character`)\cr 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) {

    }

    }

    ))

}

#' Replicate Single Values in a List

#'

#' @param initial_values (`list`)\cr initial values with names.

#' @param sizes (`list`)\cr 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) {

    )

    )

    )

        # Check for single values and replicate them according to sizes.

        }

        # Check for array handling.

        )

        }

    }

    # Check that each element of initial_values has the same length as specified in sizes.

        )

    }

}

#' Replace Character Size by Looked Up Numbers

#'

#' @param sizes (`list`)\cr may include character elements that correspond to

#'   names in the data list.

#' @param data (`list`)\cr 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) {

            )

            )

            )

        } else {

            )

        }

    }

}

#' Obtain Median and Credible Intervals from MCMC samples

#'

#' @param samples (`matrix`)\cr with samples in rows and parameters in columns.

#' @param level (`number`)\cr credibility level to use for the credible intervals.

#'

#' @returns A `data.frame` with columns `median`, `lower` and `upper`.

#' @keywords internal

#' samples_median_ci(samples)

samples_median_ci <- function(samples, level = 0.95) {

    ))

}

#' `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(...) {

        ...,

    )

}

is_windows <- function() {

}

#' `validate_time_grid`