1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
#' Create a Validation Set
#'
#' `validation_split()` takes a single random sample (without replacement) of
#' the original data set to be used for analysis. All other data points are
#' added to the assessment set (to be used as the validation set).
#' `validation_time_split()` does the same, but takes the _first_ `prop` samples
#' for training, instead of a random selection.
#' `group_validation_split()` creates splits of the data based
#' on some grouping variable, so that all data in a "group" is assigned to
#' the same split.
#' @template strata_details
#' @inheritParams vfold_cv
#' @inheritParams make_strata
#' @param prop The proportion of data to be retained for modeling/analysis.
#' @export
#' @return An tibble with classes `validation_split`, `rset`, `tbl_df`, `tbl`,
#' and `data.frame`. The results include a column for the data split objects
#' and a column called `id` that has a character string with the resample
#' identifier.
#' @examplesIf rlang::is_installed("modeldata")
#' validation_split(mtcars, prop = .9)
#'
#' data(drinks, package = "modeldata")
#' validation_time_split(drinks)
#'
#' group_validation_split(mtcars, cyl)
#' @export
validation_split <- function(data, prop = 3 / 4,
strata = NULL, breaks = 4, pool = 0.1, ...) {
if (!missing(strata)) {
strata <- tidyselect::vars_select(names(data), !!enquo(strata))
if (length(strata) == 0) {
strata <- NULL
}
}
strata_check(strata, data)
split_objs <-
mc_splits(
data = data,
prop = prop,
times = 1,
strata = strata,
breaks = breaks,
pool = pool
)
## We remove the holdout indices since it will save space and we can
## derive them later when they are needed.
split_objs$splits <- map(split_objs$splits, rm_out)
class(split_objs$splits[[1]]) <- c("val_split", "rsplit")
if (!is.null(strata)) names(strata) <- NULL
val_att <- list(
prop = prop,
strata = strata,
breaks = breaks,
pool = pool
)
new_rset(
splits = split_objs$splits,
ids = "validation",
attrib = val_att,
subclass = c("validation_split", "rset")
)
}
#' @rdname validation_split
#' @inheritParams vfold_cv
#' @inheritParams initial_time_split
#' @export
validation_time_split <- function(data, prop = 3 / 4, lag = 0, ...) {
if (!is.numeric(prop) | prop >= 1 | prop <= 0) {
rlang::abort("`prop` must be a number on (0, 1).")
}
if (!is.numeric(lag) | !(lag %% 1 == 0)) {
rlang::abort("`lag` must be a whole number.")
}
n_train <- floor(nrow(data) * prop)
if (lag > n_train) {
rlang::abort("`lag` must be less than or equal to the number of training observations.")
}
split <- rsplit(data, 1:n_train, (n_train + 1 - lag):nrow(data))
class(split) <- c("val_time_split", "val_split", "rsplit")
splits <- list(split)
val_att <- list(prop = prop, strata = FALSE)
new_rset(
splits = splits,
ids = "validation",
attrib = val_att,
subclass = c("validation_time_split", "validation_split", "rset")
)
}
#' @rdname validation_split
#' @inheritParams group_initial_split
#' @export
group_validation_split <- function(data, group, prop = 3 / 4, ..., strata = NULL, pool = 0.1) {
rlang::check_dots_empty()
group <- validate_group({{ group }}, data)
if (!missing(strata)) {
strata <- check_grouped_strata({{ group }}, {{ strata }}, pool, data)
}
split_objs <-
group_mc_splits(
data = data,
group = {{ group }},
prop = prop,
times = 1,
strata = {{ strata }},
pool = pool
)
## We remove the holdout indices since it will save space and we can
## derive them later when they are needed.
split_objs$splits <- map(split_objs$splits, rm_out)
class(split_objs$splits[[1]]) <- c("group_val_split", "val_split", "rsplit")
# This is needed for printing -- strata cannot be missing
if (is.null(strata)) strata <- FALSE
val_att <- list(
prop = prop,
group = group,
strata = strata,
pool = pool
)
new_rset(
splits = split_objs$splits,
ids = "validation",
attrib = val_att,
subclass = c("group_validation_split", "validation_split", "group_rset", "rset")
)
}
|
