From cbd535f3abde6257b6fea51d2259e78350f5bd1f Mon Sep 17 00:00:00 2001 From: Hannah Frick Date: Thu, 19 Sep 2024 19:17:47 +0100 Subject: [PATCH 1/8] switch to rlang checker --- R/misc.R | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/R/misc.R b/R/misc.R index bb202a39..8bc28cfd 100644 --- a/R/misc.R +++ b/R/misc.R @@ -98,11 +98,10 @@ add_class <- function(x, cls) { x } -strata_check <- function(strata, data) { +strata_check <- function(strata, data, call = caller_env()) { + check_string(strata, allow_null = TRUE, call = call) + if (!is.null(strata)) { - if (!is.character(strata) | length(strata) != 1) { - cli_abort("{.arg strata} should be a single name or character value.") - } if (inherits(data[, strata], "Surv")) { cli_abort("{.arg strata} cannot be a {.cls Surv} object. Use the time or event variable directly.") } From f3364640cda59d599750638ab62754992c667155 Mon Sep 17 00:00:00 2001 From: Hannah Frick Date: Thu, 19 Sep 2024 19:22:23 +0100 Subject: [PATCH 2/8] already covered by tidyselect --- R/misc.R | 3 --- 1 file changed, 3 deletions(-) diff --git a/R/misc.R b/R/misc.R index 8bc28cfd..7d016812 100644 --- a/R/misc.R +++ b/R/misc.R @@ -105,9 +105,6 @@ strata_check <- function(strata, data, call = caller_env()) { if (inherits(data[, strata], "Surv")) { cli_abort("{.arg strata} cannot be a {.cls Surv} object. Use the time or event variable directly.") } - if (!(strata %in% names(data))) { - cli_abort("{strata} is not in {.arg data}.") - } } invisible(NULL) } From d5152a9c2e5257272e297459081e9be502df2704 Mon Sep 17 00:00:00 2001 From: Hannah Frick Date: Thu, 19 Sep 2024 19:32:43 +0100 Subject: [PATCH 3/8] improve error --- R/misc.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/R/misc.R b/R/misc.R index 7d016812..55a60fa5 100644 --- a/R/misc.R +++ b/R/misc.R @@ -103,7 +103,12 @@ strata_check <- function(strata, data, call = caller_env()) { if (!is.null(strata)) { if (inherits(data[, strata], "Surv")) { - cli_abort("{.arg strata} cannot be a {.cls Surv} object. Use the time or event variable directly.") + cli_abort(c( + "{.arg strata} cannot be a {.cls Surv} object.", + "i" = "Use the time or event variable directly." + ), + call = call + ) } } invisible(NULL) From 9ea5dbc8ffd34dae656fc8ceeab29a5ad7eb945e Mon Sep 17 00:00:00 2001 From: Hannah Frick Date: Thu, 19 Sep 2024 19:39:19 +0100 Subject: [PATCH 4/8] add tests and update snaps --- tests/testthat/_snaps/boot.md | 4 ++-- tests/testthat/_snaps/make_strata.md | 5 +++-- tests/testthat/_snaps/mc.md | 4 ++-- tests/testthat/_snaps/validation_split.md | 4 ++-- tests/testthat/_snaps/vfold.md | 23 ++++++++++++++++++--- tests/testthat/test-vfold.R | 25 +++++++++++++++++++++-- 6 files changed, 52 insertions(+), 13 deletions(-) diff --git a/tests/testthat/_snaps/boot.md b/tests/testthat/_snaps/boot.md index 442c72ca..8119cead 100644 --- a/tests/testthat/_snaps/boot.md +++ b/tests/testthat/_snaps/boot.md @@ -26,8 +26,8 @@ Code bootstraps(warpbreaks, strata = c("tension", "wool")) Condition - Error in `strata_check()`: - ! `strata` should be a single name or character value. + Error in `bootstraps()`: + ! `strata` must be a single string or `NULL`, not a character vector. --- diff --git a/tests/testthat/_snaps/make_strata.md b/tests/testthat/_snaps/make_strata.md index 35a70cfb..2ffab7ba 100644 --- a/tests/testthat/_snaps/make_strata.md +++ b/tests/testthat/_snaps/make_strata.md @@ -69,6 +69,7 @@ Code strata_check("surv", df) Condition - Error in `strata_check()`: - ! `strata` cannot be a object. Use the time or event variable directly. + Error: + ! `strata` cannot be a object. + i Use the time or event variable directly. diff --git a/tests/testthat/_snaps/mc.md b/tests/testthat/_snaps/mc.md index 22446560..f7ab64cf 100644 --- a/tests/testthat/_snaps/mc.md +++ b/tests/testthat/_snaps/mc.md @@ -12,8 +12,8 @@ Code mc_cv(warpbreaks, strata = c("tension", "wool")) Condition - Error in `strata_check()`: - ! `strata` should be a single name or character value. + Error in `mc_cv()`: + ! `strata` must be a single string or `NULL`, not a character vector. # printing diff --git a/tests/testthat/_snaps/validation_split.md b/tests/testthat/_snaps/validation_split.md index a9215489..692f1440 100644 --- a/tests/testthat/_snaps/validation_split.md +++ b/tests/testthat/_snaps/validation_split.md @@ -91,8 +91,8 @@ Code validation_split(warpbreaks, strata = c("tension", "wool")) Condition - Error in `strata_check()`: - ! `strata` should be a single name or character value. + Error in `validation_split()`: + ! `strata` must be a single string or `NULL`, not a character vector. # printing diff --git a/tests/testthat/_snaps/vfold.md b/tests/testthat/_snaps/vfold.md index d590cc6b..5fb71755 100644 --- a/tests/testthat/_snaps/vfold.md +++ b/tests/testthat/_snaps/vfold.md @@ -7,7 +7,7 @@ Stratifying groups that make up 1% of the data may be statistically risky. * Consider increasing `pool` to at least 0.1 -# bad args +# strata arg is checked Code vfold_cv(iris, strata = iris$Species) @@ -21,11 +21,28 @@ Code vfold_cv(iris, strata = c("Species", "Sepal.Width")) Condition - Error in `strata_check()`: - ! `strata` should be a single name or character value. + Error in `vfold_cv()`: + ! `strata` must be a single string or `NULL`, not a character vector. + +--- + + Code + vfold_cv(iris, strata = NA) + Condition + Error in `vfold_cv()`: + ! Selections can't have missing values. --- + Code + vfold_cv(dat, strata = b) + Condition + Error in `vfold_cv()`: + ! `strata` cannot be a object. + i Use the time or event variable directly. + +# bad args + Code vfold_cv(iris, v = -500) Condition diff --git a/tests/testthat/test-vfold.R b/tests/testthat/test-vfold.R index 9b81bae1..369a0008 100644 --- a/tests/testthat/test-vfold.R +++ b/tests/testthat/test-vfold.R @@ -74,14 +74,35 @@ test_that("strata", { ) }) - -test_that("bad args", { +test_that("strata arg is checked", { expect_snapshot(error = TRUE, { vfold_cv(iris, strata = iris$Species) }) + + # errors from `strata_check()` expect_snapshot(error = TRUE, { vfold_cv(iris, strata = c("Species", "Sepal.Width")) }) + + expect_snapshot(error = TRUE, { + vfold_cv(iris, strata = NA) + }) + + # make Surv object without a dependeny on the survival package + surv_obj <- structure( + c(306, 455, 1010, 210, 883, 1, 1, 0, 1, 1), + dim = c(5L, 2L), + dimnames = list(NULL, c("time", "status")), + type = "right", + class = "Surv" + ) + dat <- data.frame(a = 1:5, b = surv_obj) + expect_snapshot(error = TRUE, { + vfold_cv(dat, strata = b) + }) +}) + +test_that("bad args", { expect_snapshot(error = TRUE, { vfold_cv(iris, v = -500) }) From 8f57e0c0245b5979aa894faa3ecf95725ae002cb Mon Sep 17 00:00:00 2001 From: Hannah Frick Date: Thu, 19 Sep 2024 19:47:45 +0100 Subject: [PATCH 5/8] rename to follow naming convention --- R/boot.R | 2 +- R/initial_validation_split.R | 4 ++-- R/mc.R | 2 +- R/misc.R | 2 +- R/validation_split.R | 2 +- R/vfold.R | 2 +- tests/testthat/_snaps/make_strata.md | 2 +- tests/testthat/test-make_strata.R | 4 ++-- tests/testthat/test-vfold.R | 2 +- 9 files changed, 11 insertions(+), 11 deletions(-) diff --git a/R/boot.R b/R/boot.R index edb40593..13cff66b 100644 --- a/R/boot.R +++ b/R/boot.R @@ -76,7 +76,7 @@ bootstraps <- if (length(strata) == 0) strata <- NULL } - strata_check(strata, data) + check_strata(strata, data) split_objs <- boot_splits( diff --git a/R/initial_validation_split.R b/R/initial_validation_split.R index 4d89ebc6..95f8f884 100644 --- a/R/initial_validation_split.R +++ b/R/initial_validation_split.R @@ -68,7 +68,7 @@ initial_validation_split <- function(data, strata <- NULL } } - strata_check(strata, data) + check_strata(strata, data) split_train <- mc_cv( data = data, @@ -209,7 +209,7 @@ group_initial_validation_split <- function(data, strata <- NULL } } - strata_check(strata, data) + check_strata(strata, data) if (missing(strata)) { split_train <- group_mc_cv( diff --git a/R/mc.R b/R/mc.R index 12d80677..35ebfd49 100644 --- a/R/mc.R +++ b/R/mc.R @@ -58,7 +58,7 @@ mc_cv <- function(data, prop = 3 / 4, times = 25, if (length(strata) == 0) strata <- NULL } - strata_check(strata, data) + check_strata(strata, data) split_objs <- mc_splits( diff --git a/R/misc.R b/R/misc.R index 55a60fa5..df2c3b70 100644 --- a/R/misc.R +++ b/R/misc.R @@ -98,7 +98,7 @@ add_class <- function(x, cls) { x } -strata_check <- function(strata, data, call = caller_env()) { +check_strata <- function(strata, data, call = caller_env()) { check_string(strata, allow_null = TRUE, call = call) if (!is.null(strata)) { diff --git a/R/validation_split.R b/R/validation_split.R index 26e5e947..bbe509b1 100644 --- a/R/validation_split.R +++ b/R/validation_split.R @@ -67,7 +67,7 @@ validation_split <- function(data, prop = 3 / 4, } } - strata_check(strata, data) + check_strata(strata, data) split_objs <- mc_splits( diff --git a/R/vfold.R b/R/vfold.R index 2a2ac616..faded51e 100644 --- a/R/vfold.R +++ b/R/vfold.R @@ -71,7 +71,7 @@ vfold_cv <- function(data, v = 10, repeats = 1, if (length(strata) == 0) strata <- NULL } - strata_check(strata, data) + check_strata(strata, data) check_repeats(repeats) if (repeats == 1) { diff --git a/tests/testthat/_snaps/make_strata.md b/tests/testthat/_snaps/make_strata.md index 2ffab7ba..764eb421 100644 --- a/tests/testthat/_snaps/make_strata.md +++ b/tests/testthat/_snaps/make_strata.md @@ -67,7 +67,7 @@ # don't stratify on Surv objects Code - strata_check("surv", df) + check_strata("surv", df) Condition Error: ! `strata` cannot be a object. diff --git a/tests/testthat/test-make_strata.R b/tests/testthat/test-make_strata.R index 3704783b..08ace53f 100644 --- a/tests/testthat/test-make_strata.R +++ b/tests/testthat/test-make_strata.R @@ -39,7 +39,7 @@ test_that("bad data", { -# strata_check() ---------------------------------------------------------- +# check_strata() ---------------------------------------------------------- test_that("don't stratify on Surv objects", { df <- data.frame( @@ -58,6 +58,6 @@ test_that("don't stratify on Surv objects", { ) expect_snapshot(error = TRUE, { - strata_check("surv", df) + check_strata("surv", df) }) }) diff --git a/tests/testthat/test-vfold.R b/tests/testthat/test-vfold.R index 369a0008..3bf8dff6 100644 --- a/tests/testthat/test-vfold.R +++ b/tests/testthat/test-vfold.R @@ -79,7 +79,7 @@ test_that("strata arg is checked", { vfold_cv(iris, strata = iris$Species) }) - # errors from `strata_check()` + # errors from `check_strata()` expect_snapshot(error = TRUE, { vfold_cv(iris, strata = c("Species", "Sepal.Width")) }) From 3b167a0831b247fbfbeee01fbf91b28a591bfe9a Mon Sep 17 00:00:00 2001 From: Hannah Frick Date: Thu, 19 Sep 2024 21:22:31 +0100 Subject: [PATCH 6/8] pass CI on older R versions? to avoid `Error in `as.data.frame.default(x[[i]], optional = TRUE)`: cannot coerce class '"Surv"' to a data.frame` --- tests/testthat/test-vfold.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-vfold.R b/tests/testthat/test-vfold.R index 3bf8dff6..f6e7bd1f 100644 --- a/tests/testthat/test-vfold.R +++ b/tests/testthat/test-vfold.R @@ -96,7 +96,9 @@ test_that("strata arg is checked", { type = "right", class = "Surv" ) - dat <- data.frame(a = 1:5, b = surv_obj) + dat <- data.frame(a = 1:5) + # add Surv object like this for older R versions (<= 4.2.3) + dat$b <- surv_obj expect_snapshot(error = TRUE, { vfold_cv(dat, strata = b) }) From a8b4d8eb75ea8a55c3f26c0549b85cf5768dafd9 Mon Sep 17 00:00:00 2001 From: Hannah Frick Date: Fri, 20 Sep 2024 10:51:59 +0100 Subject: [PATCH 7/8] Update R/misc.R Co-authored-by: Emil Hvitfeldt --- R/misc.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/misc.R b/R/misc.R index df2c3b70..ab174bae 100644 --- a/R/misc.R +++ b/R/misc.R @@ -104,7 +104,7 @@ check_strata <- function(strata, data, call = caller_env()) { if (!is.null(strata)) { if (inherits(data[, strata], "Surv")) { cli_abort(c( - "{.arg strata} cannot be a {.cls Surv} object.", + "{.field strata} cannot be a {.cls Surv} object.", "i" = "Use the time or event variable directly." ), call = call From e9d1440dd2d486293c25777f3adc96b2e465b595 Mon Sep 17 00:00:00 2001 From: Hannah Frick Date: Fri, 20 Sep 2024 10:54:36 +0100 Subject: [PATCH 8/8] update snapshots --- tests/testthat/_snaps/make_strata.md | 2 +- tests/testthat/_snaps/vfold.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/_snaps/make_strata.md b/tests/testthat/_snaps/make_strata.md index 764eb421..2c5ff244 100644 --- a/tests/testthat/_snaps/make_strata.md +++ b/tests/testthat/_snaps/make_strata.md @@ -70,6 +70,6 @@ check_strata("surv", df) Condition Error: - ! `strata` cannot be a object. + ! strata cannot be a object. i Use the time or event variable directly. diff --git a/tests/testthat/_snaps/vfold.md b/tests/testthat/_snaps/vfold.md index 5fb71755..add53300 100644 --- a/tests/testthat/_snaps/vfold.md +++ b/tests/testthat/_snaps/vfold.md @@ -38,7 +38,7 @@ vfold_cv(dat, strata = b) Condition Error in `vfold_cv()`: - ! `strata` cannot be a object. + ! strata cannot be a object. i Use the time or event variable directly. # bad args