1
#' Find Labels from rset Object
2
#'
3
#' Produce a vector of resampling labels (e.g. "Fold1") from
4
#'  an `rset` object. Currently, `nested_cv`
5
#'  is not supported.
6
#'
7
#' @param object An `rset` object
8
#' @param make_factor A logical for whether the results should be
9
#'  a character or a factor.
10
#' @param ... Not currently used.
11
#' @return A single character or factor vector.
12
#' @export
13
#' @examples
14
#' labels(vfold_cv(mtcars))
15
labels.rset <- function(object, make_factor = FALSE, ...) {
16 0
  if (inherits(object, "nested_cv"))
17 0
    stop("`labels` not implemented for nested resampling",
18 0
         call. = FALSE)
19 0
  if (make_factor)
20 0
    as.factor(object$id)
21
  else
22 0
    as.character(object$id)
23
}
24

25
#' @rdname labels.rset
26
#' @export
27
labels.vfold_cv <- function(object, make_factor = FALSE, ...) {
28 1
  if (inherits(object, "nested_cv"))
29 1
    stop("`labels` not implemented for nested resampling",
30 1
         call. = FALSE)
31 1
  is_repeated <- attr(object, "repeats") > 1
32 1
  if (is_repeated) {
33 1
    out <- as.character(paste(object$id, object$id2, sep = "."))
34
  } else
35 1
    out <- as.character(object$id)
36 1
  if (make_factor)
37 1
    out <- as.factor(out)
38 1
  out
39
}
40

41
#' Find Labels from rsplit Object
42
#'
43
#' Produce a tibble of identification variables so that single
44
#'  splits can be linked to a particular resample.
45
#'
46
#' @param object An `rsplit` object
47
#' @param ... Not currently used.
48
#' @return A tibble.
49
#' @seealso add_resample_id
50
#' @export
51
#' @examples
52
#' cv_splits <- vfold_cv(mtcars)
53
#' labels(cv_splits$splits[[1]])
54
labels.rsplit <- function(object, ...) {
55 1
  out <- if ("id" %in% names(object))
56 1
    object$id
57
  else
58 1
    tibble()
59 1
  out
60
}
61

62
## The `pretty` methods below are good for when you need to
63
## textually describe the resampling procedure. Note that they
64
## can have more than one element (in the case of nesting)
65

66

67
#' Short Descriptions of rsets
68
#'
69
#' Produce a character vector describing the resampling method.
70
#'
71
#' @param x An `rset` object
72
#' @param ... Not currently used.
73
#' @return A character vector.
74
#' @export pretty.vfold_cv
75
#' @export
76
#' @method pretty vfold_cv
77
#' @keywords internal
78
pretty.vfold_cv <- function(x, ...) {
79 1
  details <- attributes(x)
80 1
  res <- paste0(details$v, "-fold cross-validation")
81 1
  if (details$repeats > 1)
82 0
    res <- paste(res, "repeated", details$repeats, "times")
83 1
  if (details$strata)
84 0
    res <- paste(res, "using stratification")
85 1
  res
86
}
87

88
#' @export pretty.loo_cv
89
#' @export
90
#' @method pretty loo_cv
91
#' @rdname pretty.vfold_cv
92 1
pretty.loo_cv <- function(x, ...)
93 1
  "Leave-one-out cross-validation"
94

95
#' @export pretty.apparent
96
#' @export
97
#' @method pretty apparent
98
#' @rdname pretty.vfold_cv
99 0
pretty.apparent <- function(x, ...)
100 0
  "Apparent sampling"
101

102
#' @export pretty.rolling_origin
103
#' @export
104
#' @method pretty rolling_origin
105
#' @rdname pretty.vfold_cv
106 0
pretty.rolling_origin <- function(x, ...)
107 0
  "Rolling origin forecast resampling"
108

109
#' @export pretty.sliding_window
110
#' @export
111
#' @method pretty sliding_window
112
#' @rdname pretty.vfold_cv
113 0
pretty.sliding_window <- function(x, ...)
114 0
  "Sliding window resampling"
115

116
#' @export pretty.sliding_index
117
#' @export
118
#' @method pretty sliding_index
119
#' @rdname pretty.vfold_cv
120 0
pretty.sliding_index <- function(x, ...)
121 0
  "Sliding index resampling"
122

123
#' @export pretty.sliding_period
124
#' @export
125
#' @method pretty sliding_period
126
#' @rdname pretty.vfold_cv
127 0
pretty.sliding_period <- function(x, ...)
128 0
  "Sliding period resampling"
129

130
#' @export pretty.mc_cv
131
#' @export
132
#' @method pretty mc_cv
133
#' @rdname pretty.vfold_cv
134
pretty.mc_cv <- function(x, ...) {
135 1
  details <- attributes(x)
136 1
  res <- paste0(
137 1
    "Monte Carlo cross-validation (",
138 1
    signif(details$prop, 2),
139
    "/",
140 1
    signif(1 - details$prop, 2),
141 1
    ") with ",
142 1
    details$times,
143 1
    " resamples "
144
  )
145 1
  if (details$strata)
146 0
    res <- paste(res, "using stratification")
147 1
  res
148
}
149

150
#' @export pretty.validation_split
151
#' @export
152
#' @method pretty validation_split
153
#' @rdname pretty.vfold_cv
154
pretty.validation_split <- function(x, ...) {
155 1
  details <- attributes(x)
156 1
  res <- paste0(
157 1
    "Validation Set Split (",
158 1
    signif(details$prop, 2),
159
    "/",
160 1
    signif(1 - details$prop, 2),
161
    ") "
162
  )
163 1
  if (details$strata)
164 0
    res <- paste(res, "using stratification")
165 1
  res
166
}
167

168
#' @export pretty.nested_cv
169
#' @export
170
#' @method pretty nested_cv
171
#' @rdname pretty.vfold_cv
172
pretty.nested_cv <- function(x, ...) {
173 1
  details <- attributes(x)
174

175 1
  if (is_call(details$outside)) {
176 1
    class(x) <- class(x)[!(class(x) == "nested_cv")]
177 1
    outer_label <- pretty(x)
178
  } else {
179 0
    outer_label <- paste0("`", deparse(details$outside), "`")
180
  }
181

182 1
  inner_label <- if (is_call(details$inside))
183 1
    pretty(x$inner_resamples[[1]])
184
  else
185 1
    paste0("`", deparse(details$inside), "`")
186

187 1
  res <- c("Nested resampling:",
188 1
           paste(" outer:", outer_label),
189 1
           paste(" inner:", inner_label))
190 1
  res
191
}
192

193
#' @export pretty.bootstraps
194
#' @export
195
#' @method pretty bootstraps
196
#' @rdname pretty.vfold_cv
197
pretty.bootstraps <- function(x, ...) {
198 1
  details <- attributes(x)
199 1
  res <- "Bootstrap sampling"
200 1
  if (details$strata)
201 0
    res <- paste(res, "using stratification")
202 1
  if (details$apparent)
203 0
    res <- paste(res, "with apparent sample")
204 1
  res
205
}
206

207
#' @export pretty.permutations
208
#' @export
209
#' @method pretty permutations
210
#' @rdname pretty.vfold_cv
211
pretty.permutations <- function(x, ...) {
212 1
  details <- attributes(x)
213 1
  res <- "Permutation sampling"
214 1
  if (details$apparent)
215 0
    res <- paste(res, "with apparent sample")
216 1
  res
217
}
218

219
#' @export pretty.group_vfold_cv
220
#' @export
221
#' @method pretty group_vfold_cv
222
#' @rdname pretty.vfold_cv
223
pretty.group_vfold_cv  <- function(x, ...) {
224 1
  details <- attributes(x)
225 1
  paste0("Group ", details$v, "-fold cross-validation")
226
}
227

228
#' @export pretty.manual_rset
229
#' @export
230
#' @method pretty manual_rset
231
#' @rdname pretty.vfold_cv
232
pretty.manual_rset <- function(x, ...) {
233 1
  "Manual resampling"
234
}
235

236

237
#' Augment a data set with resampling identifiers
238
#'
239
#' For a data set, `add_resample_id()` will add at least one new column that
240
#'  identifies which resample that the data came from. In most cases, a single
241
#'  column is added but for some resampling methods, two or more are added.
242
#' @param .data A data frame
243
#' @param split A single `rset` object.
244
#' @param dots A single logical: should the id columns be prefixed with a "."
245
#'  to avoid name conflicts with `.data`?
246
#' @return An updated data frame.
247
#' @examples
248
#' library(dplyr)
249
#'
250
#' set.seed(363)
251
#' car_folds <- vfold_cv(mtcars, repeats = 3)
252
#'
253
#' analysis(car_folds$splits[[1]]) %>%
254
#'   add_resample_id(car_folds$splits[[1]]) %>%
255
#'   head()
256
#'
257
#' car_bt <- bootstraps(mtcars)
258
#'
259
#' analysis(car_bt$splits[[1]]) %>%
260
#'   add_resample_id(car_bt$splits[[1]]) %>%
261
#'   head()
262
#' @seealso labels.rsplit
263
#' @export
264
add_resample_id <- function(.data, split, dots = FALSE) {
265 1
  if (!inherits(dots, "logical") || length(dots) > 1) {
266 1
    stop("`dots` should be a single logical.", call. = FALSE)
267
  }
268 1
  if (!inherits(.data, "data.frame")) {
269 1
    stop("`.data` should be a data frame.", call. = FALSE)
270
  }
271 1
  if (!inherits(split, "rsplit")) {
272 1
    stop("`split` should be a single 'rset' object.", call. = FALSE)
273
  }
274 1
  labs <- labels(split)
275

276 1
  if (!tibble::is_tibble(labs) && nrow(labs) == 1) {
277 0
    stop("`split` should be a single 'rset' object.", call. = FALSE)
278
  }
279

280 1
  if (dots) {
281 1
    colnames(labs) <- paste0(".", colnames(labs))
282
  }
283

284 1
  cbind(.data, labs)
285
}
286

Read our documentation on viewing source code .

Loading