Merge pull request #537 from tidymodels/align-file-names

Align file names

Author: hfrick

R/fingerprint.R

@@ -0,0 +1,47 @@
+#' Obtain a identifier for the resamples
+#'
+#' This function returns a hash (or NA) for an attribute that is created when
+#' the `rset` was initially constructed. This can be used to compare with other
+#' resampling objects to see if they are the same.
+#' @param x An `rset` or `tune_results` object.
+#' @param ... Not currently used.
+#' @return A character value or `NA_character_` if the object was created prior
+#' to rsample version 0.1.0.
+#' @rdname get_fingerprint
+#' @aliases .get_fingerprint
+#' @examples
+#' set.seed(1)
+#' .get_fingerprint(vfold_cv(mtcars))
+#'
+#' set.seed(1)
+#' .get_fingerprint(vfold_cv(mtcars))
+#'
+#' set.seed(2)
+#' .get_fingerprint(vfold_cv(mtcars))
+#'
+#' set.seed(1)
+#' .get_fingerprint(vfold_cv(mtcars, repeats = 2))
+#' @export
+.get_fingerprint <- function(x, ...) {
+  UseMethod(".get_fingerprint")
+}
+
+#' @export
+#' @rdname get_fingerprint
+.get_fingerprint.default <- function(x, ...) {
+  cls <- class(x)
+  cli_abort("No method for objects of class{?es}: {cls}")
+}
+
+#' @export
+#' @rdname get_fingerprint
+.get_fingerprint.rset <- function(x, ...) {
+  check_dots_empty()
+  att <- attributes(x)
+  if (any(names(att) == "fingerprint")) {
+    res <- att$fingerprint
+  } else {
+    res <- NA_character_
+  }
+  res
+}

R/misc.R

@@ -118,182 +118,6 @@ split_unnamed <- function(x, f) {
   unname(out)
 }
 
-#' Obtain a identifier for the resamples
-#'
-#' This function returns a hash (or NA) for an attribute that is created when
-#' the `rset` was initially constructed. This can be used to compare with other
-#' resampling objects to see if they are the same.
-#' @param x An `rset` or `tune_results` object.
-#' @param ... Not currently used.
-#' @return A character value or `NA_character_` if the object was created prior
-#' to rsample version 0.1.0.
-#' @rdname get_fingerprint
-#' @aliases .get_fingerprint
-#' @examples
-#' set.seed(1)
-#' .get_fingerprint(vfold_cv(mtcars))
-#'
-#' set.seed(1)
-#' .get_fingerprint(vfold_cv(mtcars))
-#'
-#' set.seed(2)
-#' .get_fingerprint(vfold_cv(mtcars))
-#'
-#' set.seed(1)
-#' .get_fingerprint(vfold_cv(mtcars, repeats = 2))
-#' @export
-.get_fingerprint <- function(x, ...) {
-  UseMethod(".get_fingerprint")
-}
-
-#' @export
-#' @rdname get_fingerprint
-.get_fingerprint.default <- function(x, ...) {
-  cls <- class(x)
-  cli_abort("No method for objects of class{?es}: {cls}")
-}
-
-#' @export
-#' @rdname get_fingerprint
-.get_fingerprint.rset <- function(x, ...) {
-  check_dots_empty()
-  att <- attributes(x)
-  if (any(names(att) == "fingerprint")) {
-    res <- att$fingerprint
-  } else {
-    res <- NA_character_
-  }
-  res
-}
-
-#' Reverse the analysis and assessment sets
-#'
-#' This functions "swaps" the analysis and assessment sets of either a single
-#' `rsplit` or all `rsplit`s in the `splits` column of an `rset` object.
-#'
-#' @param x An `rset` or `rsplit` object.
-#' @param ... Not currently used.
-#'
-#' @return An object of the same class as `x`
-#'
-#' @examples
-#' set.seed(123)
-#' starting_splits <- vfold_cv(mtcars, v = 3)
-#' reverse_splits(starting_splits)
-#' reverse_splits(starting_splits$splits[[1]])
-#'
-#' @rdname reverse_splits
-#' @export
-reverse_splits <- function(x, ...) {
-  UseMethod("reverse_splits")
-}
-
-#' @rdname reverse_splits
-#' @export
-reverse_splits.default <- function(x, ...) {
-  cli_abort(
-    "{.arg x} must be either an {.cls rsplit} or an {.cls rset} object."
-  )
-}
-
-#' @rdname reverse_splits
-#' @export
-reverse_splits.permutations <- function(x, ...) {
-  cli_abort(
-    "Permutations cannot have their splits reversed."
-  )
-}
-
-#' @rdname reverse_splits
-#' @export
-reverse_splits.perm_split <- reverse_splits.permutations
-
-#' @rdname reverse_splits
-#' @export
-reverse_splits.rsplit <- function(x, ...) {
-
-  rlang::check_dots_empty()
-
-  out_splits <- list(
-    analysis = as.integer(x, data = "assessment"),
-    assessment = as.integer(x, data = "analysis")
-  )
-  out_splits <- make_splits(out_splits, x$data)
-  class(out_splits) <- class(x)
-  out_splits
-
-}
-
-#' @rdname reverse_splits
-#' @export
-reverse_splits.rset <- function(x, ...) {
-
-  rlang::check_dots_empty()
-
-  x$splits <- purrr::map(x$splits, reverse_splits)
-
-  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 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")) {
-    cli_abort("{.arg rset} must be an {.cls rset} object.")
-  }
-
-  if (inherits(rset, "manual_rset")) {
-    cli_abort("{.arg manual_rset} objects cannot be reshuffled.")
-  }
-
-  # non-random classes is defined below
-  if (any(non_random_classes %in% class(rset))) {
-    cls <- class(rset)[[1]]
-    cli::cli_warn(
-      "{.fun reshuffle_rset} will return an identical {.cls rset} when called on {.cls {cls}} objects."
-    )
-    if ("validation_set" %in% class(rset)) {
-      return(rset)
-    }
-  }
-
-  rset_type <- class(rset)[[1]]
-  split_arguments <- .get_split_args(rset)
-  if (identical(split_arguments$strata, TRUE)) {
-    cli_abort(c(
-      "Cannot reshuffle this rset ({.code attr(rset, 'strata')} is {.val 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(
-    rset_type,
-    c(list(data = rset$splits[[1]]$data), split_arguments)
-  )
-}
-
-non_random_classes <- c(
-  "sliding_index",
-  "sliding_period",
-  "sliding_window",
-  "rolling_origin",
-  "validation_time_split",
-  "validation_set"
-)
-
 #' Get the split arguments from an rset
 #' @param x An `rset` or `initial_split` object.
 #' @param allow_strata_false A logical to specify which value to use if no

R/nest.R R/nested_cv.R

@@ -0,0 +1,58 @@
+#' "Reshuffle" an rset to re-generate a new rset with the same parameters
+#'
+#' This function re-generates an rset object, using the same arguments 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")) {
+    cli_abort("{.arg rset} must be an {.cls rset} object.")
+  }
+
+  if (inherits(rset, "manual_rset")) {
+    cli_abort("{.arg manual_rset} objects cannot be reshuffled.")
+  }
+
+  # non-random classes is defined below
+  if (any(non_random_classes %in% class(rset))) {
+    cls <- class(rset)[[1]]
+    cli::cli_warn(
+      "{.fun reshuffle_rset} will return an identical {.cls rset} when called on {.cls {cls}} objects."
+    )
+    if ("validation_set" %in% class(rset)) {
+      return(rset)
+    }
+  }
+
+  rset_type <- class(rset)[[1]]
+  split_arguments <- .get_split_args(rset)
+  if (identical(split_arguments$strata, TRUE)) {
+    cli_abort(c(
+      "Cannot reshuffle this rset ({.code attr(rset, 'strata')} is {.val 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(
+    rset_type,
+    c(list(data = rset$splits[[1]]$data), split_arguments)
+  )
+}
+
+non_random_classes <- c(
+  "sliding_index",
+  "sliding_period",
+  "sliding_window",
+  "rolling_origin",
+  "validation_time_split",
+  "validation_set"
+)

R/reshuffle_rset.R

@@ -0,0 +1,68 @@
+#' Reverse the analysis and assessment sets
+#'
+#' This functions "swaps" the analysis and assessment sets of either a single
+#' `rsplit` or all `rsplit`s in the `splits` column of an `rset` object.
+#'
+#' @param x An `rset` or `rsplit` object.
+#' @param ... Not currently used.
+#'
+#' @return An object of the same class as `x`
+#'
+#' @examples
+#' set.seed(123)
+#' starting_splits <- vfold_cv(mtcars, v = 3)
+#' reverse_splits(starting_splits)
+#' reverse_splits(starting_splits$splits[[1]])
+#'
+#' @rdname reverse_splits
+#' @export
+reverse_splits <- function(x, ...) {
+  UseMethod("reverse_splits")
+}
+
+#' @rdname reverse_splits
+#' @export
+reverse_splits.default <- function(x, ...) {
+  cli_abort(
+    "{.arg x} must be either an {.cls rsplit} or an {.cls rset} object."
+  )
+}
+
+#' @rdname reverse_splits
+#' @export
+reverse_splits.permutations <- function(x, ...) {
+  cli_abort(
+    "Permutations cannot have their splits reversed."
+  )
+}
+
+#' @rdname reverse_splits
+#' @export
+reverse_splits.perm_split <- reverse_splits.permutations
+
+#' @rdname reverse_splits
+#' @export
+reverse_splits.rsplit <- function(x, ...) {
+
+  rlang::check_dots_empty()
+
+  out_splits <- list(
+    analysis = as.integer(x, data = "assessment"),
+    assessment = as.integer(x, data = "analysis")
+  )
+  out_splits <- make_splits(out_splits, x$data)
+  class(out_splits) <- class(x)
+  out_splits
+
+}
+
+#' @rdname reverse_splits
+#' @export
+reverse_splits.rset <- function(x, ...) {
+
+  rlang::check_dots_empty()
+
+  x$splits <- purrr::map(x$splits, reverse_splits)
+
+  x
+}