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

25
#' @export
26
#' @rdname complement
27
complement.rsplit <- function(x, ...) {
28 1
  if (!is_missing_out_id(x)) {
29 1
    return(x$out_id)
30
  } else {
31 1
    (1:nrow(x$data))[-unique(x$in_id)]
32
  }
33
}
34
#' @export
35
#' @rdname complement
36
complement.rof_split <- function(x, ...) {
37 1
  get_stored_out_id(x)
38
}
39
#' @export
40
#' @rdname complement
41
complement.sliding_window_split <- function(x, ...) {
42 0
  get_stored_out_id(x)
43
}
44
#' @export
45
#' @rdname complement
46
complement.sliding_index_split <- function(x, ...) {
47 0
  get_stored_out_id(x)
48
}
49
#' @export
50
#' @rdname complement
51
complement.sliding_period_split <- function(x, ...) {
52 0
  get_stored_out_id(x)
53
}
54

55
get_stored_out_id <- function(x) {
56 1
  out_id <- x$out_id
57

58 1
  if (length(out_id) == 0L) {
59 0
    return(out_id)
60
  }
61

62 1
  if (all(is.na(out_id))) {
63 0
    rlang::abort("Cannot derive the assessment set for this type of resampling.")
64
  }
65

66 1
  out_id
67
}
68

69
#' @export
70
#' @rdname complement
71
complement.apparent_split <- function(x, ...) {
72 0
  if (!is_missing_out_id(x)) {
73 0
    return(x$out_id)
74
  } else {
75 0
    1:nrow(x$data)
76
  }
77
}
78

79
#' @export
80
complement.default <- function(x, ...) {
81 1
  cls <- paste0("'", class(x), "'", collapse = ", ")
82 1
  rlang::abort(
83 1
    paste("No `complement()` method for this class(es)", cls)
84
  )
85
}
86

87
# Get the indices of the analysis set from the assessment set
88
default_complement <- function(ind, n) {
89 1
  list(analysis = setdiff(1:n, ind),
90 1
       assessment = unique(ind))
91
}
92

93

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

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

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

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

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

Read our documentation on viewing source code .

Loading