Merge pull request #527 from seb09/prevent-loo-in-vfold_cv

Prevent LOO through vfold_cv()

Author: hfrick

NEWS.md

@@ -16,6 +16,8 @@
 
 * Improved documentation and formatting: function names are now more easily identifiable through either `()` at the end or being links to the function documentation (@brshallo , #521).
 
+* `vfold_cv()` and `clustering_cv()` now error on implicit leave-one-out cross-validation (@seb09, #527).
+
 ## Bug fixes
 
 * `vfold_cv()` now utilizes the `breaks` argument correctly for repeated cross-validation (@ZWael, #471).

R/loo.R

@@ -13,7 +13,7 @@
 #' @export
 loo_cv <- function(data, ...) {
   check_dots_empty()
-  split_objs <- vfold_splits(data = data, v = nrow(data))
+  split_objs <- vfold_splits(data = data, v = nrow(data), prevent_loo = FALSE)
   split_objs <-
     list(
       splits = map(split_objs$splits, change_class),

R/vfold.R

@@ -122,10 +122,10 @@ vfold_cv <- function(data, v = 10, repeats = 1,
 }
 
 
-vfold_splits <- function(data, v = 10, strata = NULL, breaks = 4, pool = 0.1) {
+vfold_splits <- function(data, v = 10, strata = NULL, breaks = 4, pool = 0.1, prevent_loo = TRUE) {
 
   n <- nrow(data)
-  check_v(v, n, call = rlang::caller_env())
+  check_v(v, n, prevent_loo = prevent_loo, call = rlang::caller_env())
 
   if (is.null(strata)) {
     folds <- sample(rep(1:v, length.out = n))
@@ -311,7 +311,7 @@ group_vfold_splits <- function(data, group, v = NULL, balance, strata = NULL, po
   if (is.null(v)) {
     v <- max_v
   }
-  check_v(v = v, max_v = max_v, rows = "groups", call = rlang::caller_env())
+  check_v(v = v, max_v = max_v, rows = "groups", prevent_loo = FALSE, call = rlang::caller_env())
 
   indices <- make_groups(data, group, v, balance, strata)
   indices <- lapply(indices, default_complement, n = nrow(data))
@@ -332,13 +332,19 @@ add_vfolds <- function(x, v) {
   x
 }
 
-check_v <- function(v, max_v, rows = "rows", call = rlang::caller_env()) {
+check_v <- function(v, max_v, rows = "rows", prevent_loo = TRUE, call = rlang::caller_env()) {
   if (!is.numeric(v) || length(v) != 1 || v < 2) {
     rlang::abort("`v` must be a single positive integer greater than 1", call = call)
   } else if (v > max_v) {
     rlang::abort(
       glue::glue("The number of {rows} is less than `v = {v}`"), call = call
     )
+  } else if (prevent_loo && isTRUE(v == max_v)) {
+    cli_abort(c(
+      "Leave-one-out cross-validation is not supported by this function.",
+      "x" = "You set `v` to `nrow(data)`, which would result in a leave-one-out cross-validation.",
+      "i" = "Use `loo_cv()` in this case."
+    ), call = call)
   }
 }
 

tests/testthat/_snaps/clustering.md

@@ -30,6 +30,16 @@
 
     `repeats` must be a single positive integer
 
+---
+
+    Code
+      clustering_cv(mtcars, mpg, v = nrow(mtcars))
+    Condition
+      Error in `clustering_cv()`:
+      ! Leave-one-out cross-validation is not supported by this function.
+      x You set `v` to `nrow(data)`, which would result in a leave-one-out cross-validation.
+      i Use `loo_cv()` in this case.
+
 # printing
 
     Code

tests/testthat/_snaps/vfold.md

@@ -35,6 +35,16 @@
 
     `repeats` must be a single positive integer
 
+---
+
+    Code
+      vfold_cv(mtcars, v = nrow(mtcars))
+    Condition
+      Error in `vfold_cv()`:
+      ! Leave-one-out cross-validation is not supported by this function.
+      x You set `v` to `nrow(data)`, which would result in a leave-one-out cross-validation.
+      i Use `loo_cv()` in this case.
+
 # printing
 
     Code

tests/testthat/test-clustering.R

@@ -45,6 +45,7 @@ test_that("bad args", {
   expect_snapshot(error = TRUE, clustering_cv(Orange, v = 1, vars = "Tree"))
   expect_snapshot_error(clustering_cv(Orange, repeats = 0))
   expect_snapshot_error(clustering_cv(Orange, repeats = NULL))
+  expect_snapshot(error = TRUE, clustering_cv(mtcars, mpg, v = nrow(mtcars)))
 })
 
 test_that("printing", {

tests/testthat/test-vfold.R

@@ -85,6 +85,7 @@ test_that("bad args", {
   expect_snapshot_error(vfold_cv(iris, v = 150, repeats = 2))
   expect_snapshot_error(vfold_cv(Orange, repeats = 0))
   expect_snapshot_error(vfold_cv(Orange, repeats = NULL))
+  expect_snapshot(error = TRUE, vfold_cv(mtcars, v = nrow(mtcars)))
 })
 
 test_that("printing", {