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 (!all(is.na(x$out_id))) {
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 (!all(is.na(x$out_id))) {
41 0
    return(x$out_id)
42
  } else {
43 1
    (1:nrow(x$data))[-unique(x$in_id)]
44
  }
45
}
46
#' @export
47
complement.rof_split <- function(x, ...) {
48 1
  get_stored_out_id(x)
49
}
50
#' @export
51
complement.sliding_window_split <- function(x, ...) {
52 0
  get_stored_out_id(x)
53
}
54
#' @export
55
complement.sliding_index_split <- function(x, ...) {
56 0
  get_stored_out_id(x)
57
}
58
#' @export
59
complement.sliding_period_split <- function(x, ...) {
60 0
  get_stored_out_id(x)
61
}
62

63
get_stored_out_id <- function(x) {
64 1
  out_id <- x$out_id
65

66 1
  if (length(out_id) == 0L) {
67 0
    return(out_id)
68
  }
69

70 1
  if (all(is.na(out_id))) {
71 0
    rlang::abort("Cannot derive the assessment set for this type of resampling.")
72
  }
73

74 1
  out_id
75
}
76

77
#' @export
78
complement.apparent_split <- function(x, ...) {
79 1
  if (!all(is.na(x$out_id))) {
80 1
    return(x$out_id)
81
  } else {
82 0
    1:nrow(x$data)
83
  }
84
}
85

86

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

109
#' @export
110
populate.rsplit <- function(x, ...) {
111 0
  x$out_id <- complement(x, ...)
112 0
  x
113
}
114

115
#' @export
116
populate.rset <- function(x, ...) {
117 0
  x$splits <- map(x$splits, populate)
118 0
  x
119
}
120

121
## This will remove the assessment indices from an rsplit object
122
rm_out <- function(x) {
123 1
  x$out_id <- NA
124 1
  x
125
}
126

Read our documentation on viewing source code .

Loading