1
rsplit <- function(data, in_id, out_id) {
2 1
  if (!is.data.frame(data) & !is.matrix(data))
3 1
    stop("`data` must be a data frame.", call. = FALSE)
4

5 1
  if (!is.integer(in_id) | any(in_id < 1))
6 1
    stop("`in_id` must be a positive integer vector.", call. = FALSE)
7

8 1
  if(!all(is.na(out_id))) {
9 1
    if (!is.integer(out_id) | any(out_id < 1))
10 0
      stop("`out_id` must be a positive integer vector.", call. = FALSE)
11
  }
12

13 1
  if (length(in_id) == 0)
14 1
    stop("At least one row should be selected for the analysis set.",
15 1
         call. = FALSE)
16

17 1
  structure(
18 1
    list(
19 1
      data = data,
20 1
      in_id = in_id,
21 1
      out_id = out_id
22
    ),
23 1
    class = "rsplit"
24
  )
25
}
26

27
#' @export
28
print.rsplit <- function(x, ...) {
29 1
  out_char <-
30 1
    if (is_missing_out_id(x))
31 1
      paste(length(complement(x)))
32
  else
33 1
    paste(length(x$out_id))
34

35 1
  cat("<Analysis/Assess/Total>\n")
36 1
  cat("<",
37 1
      length(x$in_id), "/",
38 1
      out_char, "/",
39 1
      nrow(x$data), ">\n",
40 1
      sep = "")
41
}
42

43
#' @export
44
as.integer.rsplit <-
45
  function(x, data = c("analysis", "assessment"), ...) {
46 1
    data <- match.arg(data)
47 1
    if (data == "analysis")
48 1
      out <- x$in_id
49
    else {
50 1
      out <- if (is_missing_out_id(x))
51 1
        complement(x)
52
      else
53 1
        x$out_id
54
    }
55 1
    out
56
  }
57

58

59
#' Convert an `rsplit` object to a data frame
60
#'
61
#' The analysis or assessment code can be returned as a data
62
#'   frame (as dictated by the `data` argument) using
63
#'   `as.data.frame.rsplit`. `analysis` and
64
#'   `assessment` are shortcuts.
65
#' @param x An `rsplit` object.
66
#' @param row.names `NULL` or a character vector giving the row names for the data frame. Missing values are not allowed.
67
#' @param optional A logical: should the column names of the data be checked for legality?
68
#' @param data Either "analysis" or "assessment" to specify which data are returned.
69
#' @param ...	Additional arguments to be passed to or from methods. Not currently used.
70
#' @examples
71
#' library(dplyr)
72
#' set.seed(104)
73
#' folds <- vfold_cv(mtcars)
74
#'
75
#' model_data_1 <- folds$splits[[1]] %>% analysis()
76
#' holdout_data_1 <- folds$splits[[1]] %>% assessment()
77
#' @export
78
as.data.frame.rsplit <-
79
  function(x,
80
           row.names = NULL,
81
           optional = FALSE,
82
           data = "analysis",
83
           ...) {
84

85 1
  if (!is.null(row.names))
86 0
    warning( "`row.names` is kept for consistency with the ",
87 0
             "underlying class but non-NULL values will be ",
88 0
             "ignored.", call. = FALSE)
89 1
  if (optional)
90 0
    warning( "`optional` is kept for consistency with the ",
91 0
             "underlying class but TRUE values will be ",
92 0
             "ignored.", call. = FALSE)
93 1
  if (!is.null(x$col_id)) {
94 1
    if (identical(data, "assessment")) {
95 1
      rsplit_class <- class(x)[[2]]
96 1
      msg <- paste0("There is no assessment data set for an `rsplit` object",
97 1
                    " with class `", rsplit_class, "`.")
98 1
      rlang::abort(msg)
99
    }
100 0
    permuted_col <-
101 0
      x$data[as.integer(x, data = data, ...), x$col_id, drop = FALSE]
102 0
    x$data[, x$col_id] <- permuted_col
103 0
    return(x$data)
104
  }
105 1
  x$data[as.integer(x, data = data, ...), , drop = FALSE]
106
}
107

108
#' @rdname as.data.frame.rsplit
109
#' @export
110
analysis <- function(x, ...) {
111 1
  if (!inherits(x, "rsplit"))
112 1
    stop("`x` should be an `rsplit` object", call. = FALSE)
113 1
  as.data.frame(x, data = "analysis", ...)
114
}
115
#' @rdname as.data.frame.rsplit
116
#' @export
117
assessment <- function(x, ...){
118 1
  if (!inherits(x, "rsplit"))
119 1
    stop("`x` should be an `rsplit` object", call. = FALSE)
120 1
  as.data.frame(x, data = "assessment", ...)
121
}
122

123
#' @export
124
dim.rsplit <- function(x, ...) {
125 1
  c(
126 1
    analysis = length(x$in_id),
127 1
    assessment = length(complement(x)),
128 1
    n = nrow(x$data),
129 1
    p = ncol(x$data)
130
  )
131
}
132

133
#' @method obj_sum rsplit
134
#' @export
135
obj_sum.rsplit <- function(x, ...) {
136 0
  out_char <-
137 0
    if (is_missing_out_id(x))
138 0
      paste(length(complement(x)))
139
  else
140 0
    paste(length(x$out_id))
141

142 0
  paste0("rsplit [",
143 0
         length(x$in_id), "/",
144 0
         out_char, "]")
145
}
146

147

148
#' @method type_sum rsplit
149
#' @export
150
type_sum.rsplit <- function(x, ...) {
151 1
  out_char <-
152 1
    if (is_missing_out_id(x))
153 1
      format_n(length(complement(x)))
154
  else
155 1
    format_n(length(x$out_id))
156

157 1
  paste0(
158 1
    "split [",
159 1
    format_n(length(x$in_id)), "/",
160 1
    out_char, "]"
161
  )
162
}
163

164

165
format_n <- function(x, digits = 1) {
166 1
  case_when(
167 1
    log10(x) < 3  ~ paste(x),
168 1
    log10(x) >= 3 & log10(x) < 6 ~ paste0(round(x/1000, digits = digits), "K"),
169 1
    TRUE ~ paste0(round(x/1000000, digits = digits), "M"),
170
  )
171
}
172

173
is_rsplit <- function(x) {
174 1
  inherits(x, "rsplit")
175
}

Read our documentation on viewing source code .

Loading