1
#' Determine the Assessment Samples
2
#'
3
#' Given an `rsplit` object, `complement` will determine which
4
#'   of the data rows are contained in the assessment set. To save space,
5
#'   many of the `rset` objects will not contain indices for the
6
#'   assessment split.
7
#'
8
#' @param x An `rsplit` object
9
#' @param ... Not currently used
10
#' @return A integer vector.
11
#' @seealso [populate()]
12
#' @examples
13
#' set.seed(28432)
14
#' fold_rs <- vfold_cv(mtcars)
15
#' head(fold_rs$splits[[1]]$in_id)
16
#' fold_rs$splits[[1]]$out_id
17
#' complement(fold_rs$splits[[1]])
18
#' @export
19 1
complement <- function(x, ...)
20 1
  UseMethod("complement")
21

22
#' @export
23
complement.vfold_split <- function(x, ...) {
24 1
  if (!is_missing_out_id(x)) {
25 0
    return(x$out_id)
26
  } else {
27 1
    setdiff(1:nrow(x$data), x$in_id)
28
  }
29
}
30
#' @export
31
complement.mc_split  <- complement.vfold_split
32
#' @export
33
complement.val_split <- complement.vfold_split
34
#' @export
35
complement.loo_split <- complement.vfold_split
36
#' @export
37
complement.group_vfold_split <- complement.vfold_split
38
#' @export
39
complement.boot_split <- function(x, ...) {
40 1
  if (!is_missing_out_id(x)) {
41 0
    return(x$out_id)
42
  } else {
43 1
    (1:nrow(x$data))[-unique(x$in_id)]
44
  }
45
}
46
#' @export
47
complement.perm_split <- function(x, ...) {
48 1
  if (!is_missing_out_id(x)) {
49 0
    return(x$out_id)
50
  } else {
51 1
    (1:nrow(x$data))[-unique(x$in_id)]
52
  }
53
}
54
#' @export
55
complement.rof_split <- function(x, ...) {
56 1
  get_stored_out_id(x)
57
}
58
#' @export
59
complement.sliding_window_split <- function(x, ...) {
60 0
  get_stored_out_id(x)
61
}
62
#' @export
63
complement.sliding_index_split <- function(x, ...) {
64 0
  get_stored_out_id(x)
65
}
66
#' @export
67
complement.sliding_period_split <- function(x, ...) {
68 0
  get_stored_out_id(x)
69
}
70

71
get_stored_out_id <- function(x) {
72 1
  out_id <- x$out_id
73

74 1
  if (length(out_id) == 0L) {
75 0
    return(out_id)
76
  }
77

78 1
  if (all(is.na(out_id))) {
79 0
    rlang::abort("Cannot derive the assessment set for this type of resampling.")
80
  }
81

82 1
  out_id
83
}
84

85
#' @export
86
complement.apparent_split <- function(x, ...) {
87 1
  if (!is_missing_out_id(x)) {
88 1
    return(x$out_id)
89
  } else {
90 0
    1:nrow(x$data)
91
  }
92
}
93

94

95
#' Add Assessment Indices
96
#'
97
#' Many `rsplit` and `rset` objects do not contain indicators for
98
#'   the assessment samples. `populate()` can be used to fill the slot
99
#'   for the appropriate indices.
100
#' @param x A `rsplit` and `rset` object.
101
#' @param ... Not currently used
102
#' @return An object of the same kind with the integer indices.
103
#' @examples
104
#' set.seed(28432)
105
#' fold_rs <- vfold_cv(mtcars)
106
#'
107
#' fold_rs$splits[[1]]$out_id
108
#' complement(fold_rs$splits[[1]])
109
#'
110
#' populate(fold_rs$splits[[1]])$out_id
111
#'
112
#' fold_rs_all <- populate(fold_rs)
113
#' fold_rs_all$splits[[1]]$out_id
114
#' @export
115 0
populate <- function (x, ...) UseMethod("populate")
116

117
#' @export
118
populate.rsplit <- function(x, ...) {
119 0
  x$out_id <- complement(x, ...)
120 0
  x
121
}
122

123
#' @export
124
populate.rset <- function(x, ...) {
125 0
  x$splits <- map(x$splits, populate)
126 0
  x
127
}
128

129
## This will remove the assessment indices from an rsplit object
130
rm_out <- function(x) {
131 1
  x$out_id <- NA
132 1
  x
133
}
134

135
is_missing_out_id <- function(x) {
136 1
  identical(x$out_id, NA)
137
}
138

Read our documentation on viewing source code .

Loading