Add reshuffle_rset

NAMESPACE

@@ -295,6 +295,7 @@ export(num_range)
 export(permutations)
 export(populate)
 export(reg_intervals)
+export(reshuffle_rset)
 export(reverse_splits)
 export(rolling_origin)
 export(rsample2caret)

NEWS.md

@@ -1,5 +1,18 @@
 # rsample (development version)
 
+* rset objects should now always have all parameters used to create them as
+attributes (#329).
+
+* Objects returned by sliding functions now have an `index` attribute, where appropriate, containing the column name used as an index (#329).
+
+* Objects returned by `permutations()` now have a `permutes` attribute containing the column name used for permutation (#329).
+
+* Added `break` and `pool` as attributes to all functions which support stratification (#329).
+
+* Changed the "strata" attribute on rset objects so that it now is either a character vector identifying the column used to stratify the data, or `FALSE` if stratification was not used. (#329)
+
+* Added a new function, `reshuffle_rset()`, which takes an `rset` object and generates a new version of it using the same arguments but the current random seed. (#79, #329)
+
 * Added arguments to control how `group_vfold_cv()` combines groups. Use `balance = "groups"` to assign (roughly) the same number of groups to each fold, or `balance = "observations"` to assign (roughly) the same number of observations to each fold.
 
 * Added a `repeats` argument to `group_vfold_cv()` (#330).

R/boot.R

@@ -88,10 +88,15 @@ bootstraps <-
       split_objs <- bind_rows(split_objs, apparent(data))
     }
 
+    if (is.null(strata)) strata <- FALSE
+    names(strata) <- NULL
+
     boot_att <- list(
       times = times,
       apparent = apparent,
-      strata = !is.null(strata)
+      strata = strata,
+      breaks = breaks,
+      pool = pool
     )
 
     new_rset(

R/compat-vctrs-helpers.R

@@ -136,7 +136,7 @@ delayedAssign("rset_subclasses", {
         sliding_window         = sliding_window(test_data()),
         sliding_index          = sliding_index(test_data(), index),
         sliding_period         = sliding_period(test_data(), index, "week"),
-        manual_rset            = manual_rset(bootstraps(test_data())$splits[1:2], c("ID1", "ID2")),
+        manual_rset            = manual_rset(list(initial_time_split(test_data()), initial_time_split(test_data())), c("ID1", "ID2")),
         apparent               = apparent(test_data()),
         permutations           = permutations(test_data(), y)
       )

R/mc.R

@@ -73,10 +73,15 @@ mc_cv <- function(data, prop = 3 / 4, times = 25,
 
   split_objs$splits <- map(split_objs$splits, rm_out)
 
+  if (is.null(strata)) strata <- FALSE
+  names(strata) <- NULL
+
   mc_att <- list(
     prop = prop,
     times = times,
-    strata = !is.null(strata)
+    strata = strata,
+    breaks = breaks,
+    pool = pool
   )
 
   new_rset(

R/misc.R

@@ -219,3 +219,46 @@ reverse_splits.rset <- function(x, ...) {
 
   x
 }
+
+#' "Reshuffle" an rset to re-generate a new rset with the same parameters
+#'
+#' This function re-generates an rset object, using the same arguments as used
+#' to generate the original.
+#'
+#' @param rset The `rset` object to be reshuffled
+#'
+#' @return An rset of the same class as `rset`.
+#'
+#' @examples
+#' set.seed(123)
+#' (starting_splits <- group_vfold_cv(mtcars, cyl, v = 3))
+#' reshuffle_rset(starting_splits)
+#'
+#' @export
+reshuffle_rset <- function(rset) {
+  if (!inherits(rset, "rset")) {
+    rlang::abort("`rset` must be an rset object")
+  }
+
+  if (inherits(rset, "manual_rset")) {
+    rlang::abort("`manual_rset` objects cannot be reshuffled")
+  }
+
+  arguments <- attributes(rset)
+  useful_arguments <- names(formals(arguments$class[[1]]))
+  useful_arguments <- arguments[useful_arguments]
+  useful_arguments <- useful_arguments[!is.na(names(useful_arguments))]
+  if (identical(useful_arguments$strata, FALSE)) {
+    useful_arguments$strata <- NULL
+  } else if (identical(useful_arguments$strata, TRUE)) {
+    rlang::abort(
+      "Cannot reshuffle this rset (`attr(rset, 'strata')` is `TRUE`, not a column identifier)",
+      i = "If the original object was created with an older version of rsample, try recreating it with the newest version of the package"
+    )
+  }
+
+  do.call(
+    arguments$class[[1]],
+    c(list(data = rset$splits[[1]]$data), useful_arguments)
+  )
+}

R/permutations.R

@@ -76,7 +76,8 @@ permutations <- function(data,
   perm_att <- list(
     times = times,
     apparent = apparent,
-    col_id = col_id
+    col_id = col_id,
+    permute = names(col_id)
   )
 
   new_rset(

R/printing.R

@@ -9,7 +9,7 @@ pretty.vfold_cv <- function(x, ...) {
   if (details$repeats > 1) {
     res <- paste(res, "repeated", details$repeats, "times")
   }
-  if (details$strata) {
+  if (!identical(details$strata, FALSE)) {
     res <- paste(res, "using stratification")
   }
   res
@@ -57,7 +57,7 @@ pretty.mc_cv <- function(x, ...) {
     details$times,
     " resamples "
   )
-  if (details$strata) {
+  if (!identical(details$strata, FALSE)) {
     res <- paste(res, "using stratification")
   }
   res
@@ -73,7 +73,7 @@ pretty.validation_split <- function(x, ...) {
     signif(1 - details$prop, 2),
     ") "
   )
-  if (details$strata) {
+  if (!identical(details$strata, FALSE)) {
     res <- paste(res, "using stratification")
   }
   res
@@ -89,7 +89,7 @@ pretty.group_validation_split <- function(x, ...) {
     signif(1 - details$prop, 2),
     ") "
   )
-  if (details$strata) {
+  if (!identical(details$strata, FALSE)) {
     res <- paste(res, "using stratification")
   }
   res
@@ -124,7 +124,7 @@ pretty.nested_cv <- function(x, ...) {
 pretty.bootstraps <- function(x, ...) {
   details <- attributes(x)
   res <- "Bootstrap sampling"
-  if (details$strata) {
+  if (!identical(details$strata, FALSE)) {
     res <- paste(res, "using stratification")
   }
   if (details$apparent) {
@@ -137,7 +137,7 @@ pretty.bootstraps <- function(x, ...) {
 pretty.group_bootstraps <- function(x, ...) {
   details <- attributes(x)
   res <- "Group bootstrap sampling"
-  if (details$strata) {
+  if (!identical(details$strata, FALSE)) {
     res <- paste(res, "using stratification")
   }
   if (details$apparent) {

R/slide.R

@@ -312,6 +312,7 @@ sliding_index <- function(data,
     rlang::abort("`index` must specify exactly one column in `data`.")
   }
 
+  index_attrib <- index
   index <- data[[loc]]
 
   seq <- vctrs::vec_seq_along(data)
@@ -352,6 +353,7 @@ sliding_index <- function(data,
   ids <- names0(length(indices), prefix = "Slice")
 
   attrib <- list(
+    index = index_attrib,
     lookback = lookback,
     assess_start = assess_start,
     assess_stop = assess_stop,
@@ -406,6 +408,7 @@ sliding_period <- function(data,
     rlang::abort("`index` must specify exactly one column in `data`.")
   }
 
+  index_attrib <- index
   index <- data[[loc]]
 
   seq <- vctrs::vec_seq_along(data)
@@ -452,6 +455,7 @@ sliding_period <- function(data,
   ids <- names0(length(indices), prefix = "Slice")
 
   attrib <- list(
+    index = index_attrib,
     period = period,
     lookback = lookback,
     assess_start = assess_start,

R/validation_split.R

@@ -52,9 +52,14 @@ validation_split <- function(data, prop = 3 / 4,
   split_objs$splits <- map(split_objs$splits, rm_out)
   class(split_objs$splits[[1]]) <- c("val_split", "rsplit")
 
+  if (is.null(strata)) strata <- FALSE
+  names(strata) <- NULL
+
   val_att <- list(
     prop = prop,
-    strata = !is.null(strata)
+    strata = strata,
+    breaks = breaks,
+    pool = pool
   )
 
   new_rset(

R/vfold.R

@@ -102,7 +102,15 @@ vfold_cv <- function(data, v = 10, repeats = 1,
 
   ## Save some overall information
 
-  cv_att <- list(v = v, repeats = repeats, strata = !is.null(strata))
+  if (is.null(strata)) strata <- FALSE
+  names(strata) <- NULL
+  cv_att <- list(
+    v = v,
+    repeats = repeats,
+    strata = strata,
+    breaks = breaks,
+    pool = pool
+  )
 
   new_rset(
     splits = split_objs$splits,

_pkgdown.yml

@@ -65,6 +65,7 @@ reference:
       - make_splits
       - make_strata
       - populate
+      - reshuffle_rset
       - reverse_splits
       - rsample2caret
       - rset_reconstruct

tests/testthat/_snaps/misc.md

@@ -22,3 +22,39 @@
       Error in `reverse_splits()`:
       ! Permutations cannot have their splits reversed
 
+---
+
+    Code
+      reverse_splits(1)
+    Condition
+      Error in `reverse_splits()`:
+      ! `x` must be either an `rsplit` or an `rset` object
+
+---
+
+    Code
+      reverse_splits(permutes)
+    Condition
+      Error in `reverse_splits()`:
+      ! Permutations cannot have their splits reversed
+
+---
+
+    Code
+      reverse_splits(permutes$splits[[1]])
+    Condition
+      Error in `reverse_splits()`:
+      ! Permutations cannot have their splits reversed
+
+# reshuffle_rset is working
+
+    Cannot reshuffle this rset (`attr(rset, 'strata')` is `TRUE`, not a column identifier)
+
+---
+
+    `manual_rset` objects cannot be reshuffled
+
+---
+
+    `rset` must be an rset object
+