move .filter_eval_time to standalone (#1034)

* move filter function to standalone

* reverse changelog order

* versioning and docs

* comments and updated date

* move corresponding test

* revert msg formatting

---------

Co-authored-by: ‘topepo’ <‘mxkuhn@gmail.com’>
Co-authored-by: Hannah Frick <hannah@posit.co>

Author: 3 people

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: parsnip
 Title: A Common API to Modeling and Analysis Functions
-Version: 1.1.1.9004
+Version: 1.1.1.9005
 Authors@R: c(
     person("Max", "Kuhn", , "max@posit.co", role = c("aut", "cre")),
     person("Davis", "Vaughan", , "davis@posit.co", role = "aut"),

NEWS.md

@@ -1,5 +1,7 @@
 # parsnip (development version)
 
+* `.filter_eval_time()` was moved to the survival standalone file. 
+
 * Improved errors and documentation related to special terms in formulas. See `?model_formula` to learn more. (#770, #1014)
 
 * Improved errors in cases where the outcome column is mis-specified. (#1003)

R/standalone-survival.R

@@ -1,26 +1,31 @@
 # ---
 # repo: tidymodels/parsnip
 # file: standalone-survival.R
-# last-updated: 2023-06-14
+# last-updated: 2023-12-08
 # license: https://unlicense.org
 # ---
 
-# This file provides a portable set of helper functions for Surv objects
+# This file provides a portable set of helper functions for survival analysis.
+#
 
 # ## Changelog
-
-# 2023-02-28:
-# * Initial version
+# 2023-12-08
+# * move .filter_eval_time to this file
 #
-# 2023-05-18
-# * added time to factor conversion
+# 2023-11-09
+# * make sure survival vectors are unnamed.
 #
 # 2023-06-14
 # * removed time to factor conversion
 #
-# 2023-11-09
-# * make sure survival vectors are unnamed.
-
+# 2023-05-18
+# * added time to factor conversion
+#
+# 2023-02-28:
+# * Initial version
+#
+# ------------------------------------------------------------------------------
+#
 # @param surv A [survival::Surv()] object
 # @details
 # `.is_censored_right()` always returns a logical while
@@ -51,17 +56,21 @@
   attr(surv, "type")
 }
 
-.check_cens_type <- function(surv, type = "right", fail = TRUE, call = rlang::caller_env()) {
-  .is_surv(surv, call = call)
-  obj_type <- .extract_surv_type(surv)
-  good_type <- all(obj_type %in% type)
-  if (!good_type && fail) {
-    c_list <- paste0("'", type, "'")
-    msg <- cli::format_inline("For this usage, the allowed censoring type{?s} {?is/are}: {c_list}")
-    rlang::abort(msg, call = call)
+.check_cens_type <-
+  function(surv,
+           type = "right",
+           fail = TRUE,
+           call = rlang::caller_env()) {
+    .is_surv(surv, call = call)
+    obj_type <- .extract_surv_type(surv)
+    good_type <- all(obj_type %in% type)
+    if (!good_type && fail) {
+      c_list <- paste0("'", type, "'")
+      msg <- cli::format_inline("For this usage, the allowed censoring type{?s} {?is/are}: {c_list}")
+      rlang::abort(msg, call = call)
+    }
+    good_type
   }
-  good_type
-}
 
 .is_censored_right <- function(surv) {
   .check_cens_type(surv, type = "right", fail = FALSE)
@@ -88,12 +97,45 @@
   .is_surv(surv)
   res <-   surv[, "status"]
   un_vals <- sort(unique(res))
-  event_type_to_01 <- !(.extract_surv_type(surv) %in% c("interval", "interval2", "mstate"))
+  event_type_to_01 <-
+    !(.extract_surv_type(surv) %in% c("interval", "interval2", "mstate"))
   if (
     event_type_to_01 &&
     (identical(un_vals, 1:2) | identical(un_vals, c(1.0, 2.0))) ) {
     res <- res - 1
   }
   unname(res)
 }
+
 # nocov end
+
+# ------------------------------------------------------------------------------
+
+# @param eval_time A vector of numeric time points
+# @details
+# `.filter_eval_time` checks the validity of the time points.
+#
+# @return A potentially modified vector of time points.
+.filter_eval_time <- function(eval_time, fail = TRUE) {
+  if (!is.null(eval_time)) {
+    eval_time <- as.numeric(eval_time)
+  }
+  eval_time_0 <- eval_time
+  # will still propagate nulls:
+  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 (fail && identical(eval_time, numeric(0))) {
+    cli::cli_abort(
+      "There were no usable evaluation times (finite, non-missing, and >= 0).",
+      call = NULL
+    )
+  }
+  if (!identical(eval_time, eval_time_0)) {
+    diffs <- setdiff(eval_time_0, eval_time)
+    cli::cli_warn("There {?was/were} {length(diffs)} inappropriate evaluation
+                  time point{?s} that {?was/were} removed.", call = NULL)
+
+  }
+  eval_time
+}

R/survival-censoring-weights.R

@@ -18,31 +18,6 @@ trunc_probs <- function(probs, trunc = 0.01) {
   probs
 }
 
-.filter_eval_time <- function(eval_time, fail = TRUE) {
-  if (!is.null(eval_time)) {
-    eval_time <- as.numeric(eval_time)
-  }
-  eval_time_0 <- eval_time
-  # will still propagate nulls:
-  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 (fail && identical(eval_time, numeric(0))) {
-    rlang::abort(
-      "There were no usable evaluation times (finite, non-missing, and >= 0).",
-      call = NULL
-    )
-  }
-  if (!identical(eval_time, eval_time_0)) {
-    diffs <- setdiff(eval_time_0, eval_time)
-    msg <-
-      cli::pluralize(
-        "There {?was/were} {length(diffs)} inappropriate evaluation time point{?s} that {?was/were} removed.")
-    rlang::warn(msg)
-  }
-  eval_time
-}
-
 # nocov start
 # these are tested in extratests
 

tests/testthat/_snaps/survival-censoring-weights.md renamed to tests/testthat/_snaps/standalone-survival.md

@@ -0,0 +1,28 @@
+test_that(".filter_eval_time()", {
+  times_basic <- 0:10
+  expect_equal(
+    parsnip:::.filter_eval_time(times_basic),
+    times_basic
+  )
+
+  times_dont_reorder <- c(10, 1:9)
+  expect_equal(
+    parsnip:::.filter_eval_time(times_dont_reorder),
+    times_dont_reorder
+  )
+
+  expect_null(parsnip:::.filter_eval_time(NULL))
+
+  times_duplicated <- c(times_basic, times_basic)
+  expect_snapshot(
+    parsnip:::.filter_eval_time(times_duplicated)
+  )
+
+  expect_snapshot(error = TRUE, parsnip:::.filter_eval_time(-1))
+
+  times_remove_plural <- c(Inf, NA, -3, times_basic)
+  expect_snapshot(parsnip:::.filter_eval_time(times_remove_plural))
+
+  times_remove_singular <- c(-3, times_basic)
+  expect_snapshot(parsnip:::.filter_eval_time(times_remove_singular))
+})

tests/testthat/test-standalone-survival.R

@@ -21,32 +21,3 @@ test_that("probability truncation via trunc_probs()", {
     probs
   )
 })
-
-test_that(".filter_eval_time()", {
-  times_basic <- 0:10
-  expect_equal(
-    parsnip:::.filter_eval_time(times_basic),
-    times_basic
-  )
-
-  times_dont_reorder <- c(10, 1:9)
-  expect_equal(
-    parsnip:::.filter_eval_time(times_dont_reorder),
-    times_dont_reorder
-  )
-
-  expect_null(parsnip:::.filter_eval_time(NULL))
-
-  times_duplicated <- c(times_basic, times_basic)
-  expect_snapshot(
-    parsnip:::.filter_eval_time(times_duplicated)
-  )
-
-  expect_snapshot(error = TRUE, parsnip:::.filter_eval_time(-1))
-
-  times_remove_plural <- c(Inf, NA, -3, times_basic)
-  expect_snapshot(parsnip:::.filter_eval_time(times_remove_plural))
-
-  times_remove_singular <- c(-3, times_basic)
-  expect_snapshot(parsnip:::.filter_eval_time(times_remove_singular))
-})