diff --git a/DESCRIPTION b/DESCRIPTION index 944167379..e6477f6ed 100644 --- a/DESCRIPTION +++ b/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"), diff --git a/NEWS.md b/NEWS.md index f409d97eb..55d83f157 100644 --- a/NEWS.md +++ b/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) diff --git a/R/standalone-survival.R b/R/standalone-survival.R index df4808081..bf46c1346 100644 --- a/R/standalone-survival.R +++ b/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,7 +97,8 @@ .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))) ) { @@ -96,4 +106,36 @@ } 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 +} diff --git a/R/survival-censoring-weights.R b/R/survival-censoring-weights.R index 28b935c0c..39ab2626d 100644 --- a/R/survival-censoring-weights.R +++ b/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 diff --git a/tests/testthat/_snaps/survival-censoring-weights.md b/tests/testthat/_snaps/standalone-survival.md similarity index 100% rename from tests/testthat/_snaps/survival-censoring-weights.md rename to tests/testthat/_snaps/standalone-survival.md diff --git a/tests/testthat/test-standalone-survival.R b/tests/testthat/test-standalone-survival.R new file mode 100644 index 000000000..eac864921 --- /dev/null +++ b/tests/testthat/test-standalone-survival.R @@ -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)) +}) diff --git a/tests/testthat/test-survival-censoring-weights.R b/tests/testthat/test-survival-censoring-weights.R index 3885c35a4..770b5f6a1 100644 --- a/tests/testthat/test-survival-censoring-weights.R +++ b/tests/testthat/test-survival-censoring-weights.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)) -})