Potato/inner/calibration split

NAMESPACE

@@ -25,6 +25,12 @@ S3method(dim,initial_validation_split)
 S3method(dim,rsplit)
 S3method(get_rsplit,default)
 S3method(get_rsplit,rset)
+S3method(inner_split,apparent_split)
+S3method(inner_split,clustering_split)
+S3method(inner_split,group_mc_split)
+S3method(inner_split,group_vfold_split)
+S3method(inner_split,mc_split)
+S3method(inner_split,vfold_split)
 S3method(int_bca,bootstraps)
 S3method(int_pctl,bootstraps)
 S3method(int_t,bootstraps)
@@ -343,6 +349,7 @@ S3method(vec_restore,validation_split)
 S3method(vec_restore,validation_time_split)
 S3method(vec_restore,vfold_cv)
 export(.get_fingerprint)
+export(.get_split_args)
 export(add_resample_id)
 export(all_of)
 export(analysis)
@@ -368,6 +375,7 @@ export(initial_split)
 export(initial_time_split)
 export(initial_validation_split)
 export(initial_validation_time_split)
+export(inner_split)
 export(int_bca)
 export(int_pctl)
 export(int_t)

NEWS.md

@@ -1,5 +1,7 @@
 # rsample (development version)
 
+* The new `inner_split()` function and its methods for various resamples is for usage in tune to create a inner resample of the analysis set to fit the preprocessor and model on one part and the post-processor on the other part (#483).
+
 ## Bug fixes
 
 * `vfold_cv()` now utilizes the `breaks` argument correctly for repeated cross-validation (@ZWael, #471).

R/inner_split.R

@@ -0,0 +1,159 @@
+#' Inner split of the analysis set for fitting a post-processor
+#' 
+#' @param x An `rsplit` object.
+#' @param split_args A list of arguments to be used for the inner split.
+#' @param ... Not currently used.
+#' @return An `rsplit` object.
+#' @details
+#' `rsplit` objects live most commonly inside of an `rset` object. The 
+#' `split_args` argument can be the output of [.get_split_args()] on that 
+#' corresponding `rset` object, even if some of the arguments used to creat the 
+#' `rset` object are not needed for the inner split. 
+#' * For `mc_split` and `group_mc_split` objects, `inner_split()` will ignore 
+#' `split_args$times`.
+#' * For `vfold_split` and `group_vfold_split` objects, it will ignore 
+#' `split_args$times` and `split_args$repeats`. `split_args$v` will be used to 
+#' set `split_args$prop` to `1 - 1/v` if `prop` is not already set and otherwise 
+#' ignored. The method 
+#' for `group_vfold_split` will always use `split_args$balance = NULL`.
+#' * For `clustering_split` objects, it will ignore `split_args$repeats`.
+#'  
+#' @keywords internal
+#' @export
+inner_split <- function(x, ...) {
+  UseMethod("inner_split")
+}
+
+# mc ---------------------------------------------------------------------
+
+#' @rdname inner_split
+#' @export
+inner_split.mc_split <- function(x, split_args, ...) {
+  check_dots_empty() 
+
+  analysis_set <- analysis(x)
+
+  split_args$times <- 1
+  split_inner <- rlang::inject(
+    mc_splits(analysis_set, !!!split_args)
+  )
+  split_inner <- split_inner$splits[[1]]
+
+  class_inner <- paste0(class(x)[1], "_inner")
+  split_inner <- add_class(split_inner, class_inner)
+  split_inner
+}
+
+#' @rdname inner_split
+#' @export
+inner_split.group_mc_split <- function(x, split_args, ...) {
+  check_dots_empty() 
+
+  analysis_set <- analysis(x)
+
+  split_args$times <- 1
+  split_inner <- rlang::inject(
+    group_mc_splits(analysis_set, !!!split_args)
+  )
+  split_inner <- split_inner$splits[[1]]
+
+  class_inner <- paste0(class(x)[1], "_inner")
+  split_inner <- add_class(split_inner, class_inner)
+  split_inner
+}
+
+
+# vfold ------------------------------------------------------------------
+
+#' @rdname inner_split
+#' @export
+inner_split.vfold_split <- function(x, split_args, ...) {
+  check_dots_empty() 
+
+  analysis_set <- analysis(x)
+
+  # TODO should this be done outside of rsample, 
+  # in workflows or tune?
+  if (is.null(split_args$prop)) {
+    split_args$prop <- 1 - 1/split_args$v
+  }
+  # use mc_splits for a random split
+  split_args$times <- 1
+  split_args$v <- NULL
+  split_args$repeats <- NULL
+  split_inner <- rlang::inject(
+    mc_splits(analysis_set, !!!split_args)
+  )
+  split_inner <- split_inner$splits[[1]]
+
+  class_inner <- paste0(class(x)[1], "_inner")
+  class(split_inner) <- c(class_inner, class(x))
+  split_inner
+}
+
+#' @rdname inner_split
+#' @export
+inner_split.group_vfold_split <- function(x, split_args, ...) {
+  check_dots_empty() 
+
+  analysis_set <- analysis(x)
+
+  # TODO should this be done outside of rsample, 
+  # in workflows or tune?
+  if (is.null(split_args$prop)) {
+    split_args$prop <- 1 - 1/split_args$v
+  }
+
+  # use group_mc_splits for a random split
+  split_args$times <- 1
+  split_args$v <- NULL
+  split_args$repeats <- NULL
+  split_args$balance <- NULL
+  split_inner <- rlang::inject(
+    group_mc_splits(analysis_set, !!!split_args)
+  )
+  split_inner <- split_inner$splits[[1]]
+
+  class_inner <- paste0(class(x)[1], "_inner")
+  class(split_inner) <- c(class_inner, class(x))
+  split_inner
+}
+
+# clustering -------------------------------------------------------------
+
+#' @rdname inner_split
+#' @export
+inner_split.clustering_split <- function(x, split_args, ...) {
+  check_dots_empty() 
+
+  analysis_set <- analysis(x)
+
+  # TODO: reduce the number of clusters by 1 in tune?
+  split_args$repeats <- 1
+  split_inner <- rlang::inject(
+    clustering_cv(analysis_set, !!!split_args)
+  )
+  split_inner <- split_inner$splits[[1]]
+
+  class_inner <- paste0(class(x)[1], "_inner")
+  class(split_inner) <- c(class_inner, class(x))
+  split_inner
+}
+
+
+# apparent ---------------------------------------------------------------
+
+#' @rdname inner_split
+#' @export
+inner_split.apparent_split <- function(x, ...) {
+  check_dots_empty() 
+
+  analysis_set <- analysis(x)
+
+  split_inner <- apparent(analysis_set)
+  split_inner <- split_inner$splits[[1]]
+
+  class_inner <- paste0(class(x)[1], "_inner")
+  class(split_inner) <- c(class_inner, class(x))
+  split_inner
+}

R/misc.R

@@ -271,22 +271,18 @@ reshuffle_rset <- function(rset) {
     }
   }
 
-  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)) {
+  rset_type <- class(rset)[[1]]
+  split_arguments <- .get_split_args(rset)
+  if (identical(split_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)
+    rset_type,
+    c(list(data = rset$splits[[1]]$data), split_arguments)
   )
 }
 
@@ -299,6 +295,22 @@ non_random_classes <- c(
   "validation_set"
 )
 
+#' Get the split arguments from an rset
+#' @param rset An `rset` object.
+#' @return A list of arguments used to create the rset.
+#' @keywords internal
+#' @export
+.get_split_args <- function(rset) {
+  all_attributes <- attributes(rset)
+  args <- names(formals(all_attributes$class[[1]]))
+  split_args <- all_attributes[args]
+  split_args <- split_args[!is.na(names(split_args))]
+  if (identical(split_args$strata, FALSE)) {
+    split_args$strata <- NULL
+  }
+  split_args
+}
+
 #' Retrieve individual rsplits objects from an rset
 #'
 #' @param x The `rset` object to retrieve an rsplit from.