survival time to binary conversion

NAMESPACE

@@ -157,12 +157,15 @@ export(.convert_form_to_xy_new)
 export(.convert_xy_to_form_fit)
 export(.convert_xy_to_form_new)
 export(.dat)
+export(.extract_surv_status)
+export(.extract_surv_time)
 export(.facts)
 export(.lvls)
 export(.model_param_name_key)
 export(.obs)
 export(.organize_glmnet_pred)
 export(.preds)
+export(.time_as_binary_event)
 export(.x)
 export(.y)
 export(C5.0_train)

NEWS.md

@@ -6,6 +6,8 @@
 
 * For BART models with the `dbarts` engine, `predict()` can now also return the standard error for confidence and prediction intervals (#976).
 
+* A few censored regression helper functions were exported: `.extract_surv_status()`, `.extract_surv_time()`, and `.time_as_binary_event()` (#973).
+
 
 # parsnip 1.1.0
 

R/standalone-survival.R

@@ -1,7 +1,7 @@
 # ---
 # repo: tidymodels/parsnip
 # file: standalone-survival.R
-# last-updated: 2023-02-28
+# last-updated: 2023-05-18
 # license: https://unlicense.org
 # ---
 
@@ -11,7 +11,9 @@
 
 # 2023-02-28:
 # * Initial version
-
+#
+# 2023-05-18
+# * added time to factor conversion
 
 # @param surv A [survival::Surv()] object
 # @details
@@ -20,10 +22,15 @@
 #
 # `.extract_status()` will return the data as 0/1 even if the original object
 # used the legacy encoding of 1/2. See [survival::Surv()].
+#
+# `.time_as_binary_event()` takes a Surv object and converts it to a binary
+# outcome (if possible).
+
 # @return
 # - `.extract_surv_status()` returns a vector.
 # - `.extract_surv_time()` returns a vector when the type is `"right"` or `"left"`
 #    and a tibble otherwise.
+# - `.time_as_binary_event()` returns a two-level factor.
 # - Functions starting with `.is_` or `.check_` return logicals although the
 #   latter will fail when `FALSE`.
 
@@ -85,4 +92,24 @@
   res
 }
 
+.time_as_binary_event <- function(surv, eval_time) {
+  eval_time <- eval_time[!is.na(eval_time)]
+  eval_time <- eval_time[eval_time >= 0 & is.finite(eval_time)]
+  eval_time <- unique(eval_time)
+  if (length(eval_time) != 1 || !is.numeric(eval_time)) {
+    stop("'eval_time' should be a single, complete, finite numeric value.")
+  }
+
+  event_time <- .extract_surv_time(surv)
+  status <- .extract_surv_status(surv)
+  is_event_before_t <- event_time <= eval_time & status == 1
+  # Three possible contributions to the statistic from Graf 1999
+  # Censoring time before eval_time, no contribution (Graf category 3)
+  binary_res <- rep(NA_character_, length(event_time))
+  # A real event prior to eval_time (Graf category 1)
+  binary_res <- ifelse(is_event_before_t, "event", binary_res)
+  # Observed time greater than eval_time (Graf category 2)
+  binary_res <- ifelse(event_time > eval_time, "non-event", binary_res)
+  factor(binary_res, levels = c("event", "non-event"))
+}
 # nocov end

R/survival-helpers.R

@@ -0,0 +1,51 @@
+# standalone-survival.R is loaded already. We'll capture the environment where
+# the functions of interest reside. We then document them and connect the
+# functions to their docs via the use of @alias. After the roxygen comments,
+# assign the function by referencing its name in the environment.
+
+surv_ns <- environment(.extract_surv_status)
+
+#' Extract survival time
+#'
+#' Extract the time component(s) from a [survival::Surv()] object.
+#' @name .extract_surv_time
+#' @aliases .extract_surv_time
+#' @param surv A single [survival::Surv()] object.
+#' @return A vector when the type is `"right"` or `"left"` and a tibble otherwise.
+#' @export
+assign(".extract_surv_time", surv_ns[[".extract_surv_time"]])
+
+#' Extract survival status
+#'
+#' Extract the status from a [survival::Surv()] object.
+#' @name .extract_surv_status
+#' @aliases .extract_surv_status
+#' @param surv A single [survival::Surv()] object.
+#' @return A numeric vector.
+#' @export
+assign(".extract_surv_status", surv_ns[[".extract_surv_status"]])
+
+#' Convert survival objects to binary factors
+#'
+#' For a given evaluation time, convert a [survival::Surv()] object to a binary
+#' factor with levels `"event"` and `"non-event"`.
+#'
+#' @name .time_as_binary_event
+#' @param surv A single [survival::Surv()] object.
+#' @param eval_time A single numeric value for the evaluation time.
+#' @return A two level factor.
+#' @details
+#' The following three cases can occur:
+#'  - **Events**: Evaluation time is greater than or equal to the event time
+#' ("it has already happened").
+#'  - **Non-events**: Evaluation time is less than the observed time, censored
+#'  or not ("nothing has happened yet").
+#'  - **Ambiguous outcomes**: Evaluation time is greater than or equal to the
+#'  observed censored time ("we don't know if anything might have happened by now").
+#'  A missing value is returned for these observations.
+#'
+#' @references  Graf, E., Schmoor, C., Sauerbrei, W., and Schumacher, M. (1999).
+#' "Assessment and Comparison of Prognostic Classification Schemes for Survival Data."
+#' _Statistics in Medicine_, 18, 2529-2545.
+#' @export
+assign(".time_as_binary_event", surv_ns[[".time_as_binary_event"]])

_pkgdown.yml

@@ -104,4 +104,7 @@ reference:
       - required_pkgs
       - required_pkgs.model_spec
       - req_pkgs
+      - .extract_surv_status
+      - .extract_surv_time
       - .model_param_name_key
+      - .time_as_binary_event