R/extract_time_to_event.R

In cifmodeling: Visualization and Polytomous Modeling of Survival and Competing Risks

#' Extract per-stratum event times from a formula and data
#'
#' @description
#' Creates a list of event times that can be passed to downstream
#' visualization or analysis functions such as `competing.risk.time` or
#' `intercurrent.event.time` in [cifplot()] and [cifpanel()].
#' Event types are specified by event 1, event 2, censoring, or user-specified codes.
#'
#' @param formula A model formula specifying the outcome and (optionally) \code{strata()}.
#' @param data A data frame containing variables in \code{formula}.
#' @param weights Optional numeric case weights or the name of a weight column.
#'   Rows with missing weights are excluded consistently with curve estimation.
#' @param subset.condition Optional expression (as a character string) defining a
#'   subset of \code{data} to analyse. Defaults to \code{NULL}.
#' @param na.action Function to handle missing values (default: \code{na.omit} in \pkg{stats}).
#' @param which.event One of \code{"event1"}, \code{"event2"}, \code{"censor"},
#'   \code{"censoring"}, or \code{"user_specified"}, indicating which event type
#'   to extract times for.
#' @param code.event1,code.event2,code.censoring Integer codes representing the
#'   event and censoring categories. Defaults are \code{1}, \code{2}, and
#'   \code{0}, respectively.
#' @param code.user.specified When \code{which.event = "user_specified"},
#'   the integer event code to extract (e.g., 3 for an intercurrent event).
#' @param read.unique.time Logical if \code{TRUE}, only unique and sorted time points
#'   are returned for each stratum.
#' @param drop.empty Logical if \code{TRUE} (default), strata with no events are
#'   dropped from the returned list. Set to \code{FALSE} to retain empty strata
#'   as \code{numeric(0)} vectors (useful for diagnostics or consistent list length).
#'
#' @return
#' A named list of numeric vectors, where each element corresponds to a stratum
#' and contains the event times of the selected type.
#'
#' @details
#' This function is typically used internally by plotting and model functions,
#' but can also be called directly to inspect the per-stratum event-time
#' structure of a data frame.
#'
#' @examples
#' data(diabetes.complications)
#' output <- extract_time_to_event(Event(t,epsilon) ~ fruitq,
#'                                 data = diabetes.complications,
#'                                 which.event = "event2")
#' cifplot(Event(t,epsilon) ~ fruitq,
#'         data = diabetes.complications,
#'         outcome.type="competing-risk",
#'         add.conf=FALSE,
#'         add.risktable=FALSE,
#'         add.censor.mark=FALSE,
#'         add.competing.risk.mark=TRUE,
#'         competing.risk.time=output,
#'         label.y="CIF of diabetic retinopathy",
#'         label.x="Years from registration")
#' @name extract_time_to_event
#' @section Lifecycle:
#' \lifecycle{stable}
#'
#' @seealso [polyreg()] for log-odds product modeling of CIFs; [cifcurve()] for KM/AJ estimators; [cifplot()] for display of a CIF; [cifpanel()] for display of multiple CIFs; [ggsurvfit][ggsurvfit], [patchwork][patchwork] and [modelsummary][modelsummary] for display helpers.
#' @export
extract_time_to_event <- function(
    formula,
    data,
    weights = NULL,
    subset.condition = NULL,
    na.action = na.omit,
    which.event = c("event2", "event1", "censor", "censoring", "user_specified"),
    code.event1 = 1,
    code.event2 = 2,
    code.censoring = 0,
    code.user.specified = NULL,
    read.unique.time = TRUE,
    drop.empty = TRUE
){
  which.event <- match.arg(which.event)
  weights.expr <- substitute(weights)
  out_read_surv <- eval(substitute(
    util_read_surv(
      formula = formula, data = data, weights = arg_weights,
      code.event1 = code.event1, code.event2 = code.event2, code.censoring = code.censoring,
      subset.condition = subset.condition, na.action = na.action,
      auto_message = FALSE, validate.observed.codes = FALSE
    ),
    list(arg_weights = weights.expr)
  ))
  util_get_event_time(
    out_read_surv = out_read_surv,
    which.event = which.event, code.user.specified = code.user.specified,
    read.unique.time = read.unique.time, drop.empty = drop.empty
  )
}

util_get_event_time <- function(
    out_read_surv,
    which.event = c("event2", "event1", "censor", "censoring", "user_specified"),
    code.user.specified = NULL,
    read.unique.time = TRUE,
    drop.empty = TRUE
){
  which.event <- match.arg(which.event)

  if (is.null(out_read_surv) || !is.list(out_read_surv)) .err("req", arg = "out_read_surv (list)")

  strata <- out_read_surv$strata
  if (is.null(strata)) strata <- factor(rep("all", length(out_read_surv$t)))
  if (is.factor(strata)) strata <- as.character(strata)

  tvec    <- suppressWarnings(as.numeric(out_read_surv$t))
  epsilon <- suppressWarnings(as.numeric(out_read_surv$epsilon))
  if (anyNA(tvec))   .err("na",          arg = "out_read_surv$t")
  if (any(tvec < 0)) .err("nonneg",      arg = "out_read_surv$t")

  pick <- switch(
    which.event,
    event1 = as.integer(out_read_surv$d1),
    event2 = as.integer(out_read_surv$d2),
    censor = as.integer(out_read_surv$d0),
    censoring = as.integer(out_read_surv$d0),
    user_specified = {
      if (is.null(code.user.specified)) .err("req", arg = "user_specified_code")
      as.integer(epsilon == as.numeric(code.user.specified))
    }
  )

  labs <- unique(strata)

  if (length(labs) == 1L) {
    idx <- (strata == labs[[1L]]) & (pick > 0L) & is.finite(tvec)
    tt  <- tvec[idx]
    tt  <- if (isTRUE(read.unique.time)) sort(unique(tt)) else sort(tt)
    if (length(tt) == 0L && isTRUE(drop.empty)) return(numeric(0))
    return(tt)
  }

  out  <- stats::setNames(vector("list", length(labs)), labs)
  for (s in labs) {
    idx <- (strata == s) & (pick > 0L) & is.finite(tvec)
    tt  <- tvec[idx]
    tt  <- if (isTRUE(read.unique.time)) sort(unique(tt)) else sort(tt)
    if (length(tt) > 0 || !isTRUE(drop.empty)) out[[s]] <- tt
  }
  if (isTRUE(drop.empty)) out <- out[vapply(out, length, integer(1)) > 0]
  out
}