1
#' Constructor for new rset objects
2
#' @param splits A list column of `rsplits` or a tibble with a single column
3
#'  called "splits" with a list column of `rsplits`.
4
#' @param ids A character vector or a tibble with one or more columns that
5
#' begin with "id".
6
#' @param attrib An optional named list of attributes to add to the object.
7
#' @param subclass A character vector of subclasses to add.
8
#' @return An `rset` object.
9
#' @keywords internal
10
#' @export
11
new_rset <-  function(splits, ids, attrib = NULL,
12
                      subclass = character()) {
13 1
  stopifnot(is.list(splits))
14 1
  if (!is_tibble(ids)) {
15 1
    ids <- tibble(id = ids)
16
  } else {
17 1
    if (!all(grepl("^id", names(ids)))) {
18 1
      rlang::abort("The `ids` tibble column names should start with 'id'.")
19
    }
20
  }
21 1
  either_type <- function(x)
22 1
    is.character(x) | is.factor(x)
23 1
  ch_check <- vapply(ids, either_type, c(logical = TRUE))
24 1
  if (!all(ch_check)) {
25 1
    rlang::abort("All ID columns should be character or factor vectors.")
26
  }
27

28 1
  if (!is_tibble(splits)) {
29 1
    splits <- tibble(splits = splits)
30
  } else {
31 0
    if (ncol(splits) > 1 | names(splits)[1] != "splits") {
32 0
      rlang::abort(
33 0
        "The `splits` tibble should have a single column named `splits`."
34
      )
35
    }
36
  }
37

38 1
  where_rsplits <- vapply(splits[["splits"]], is_rsplit, logical(1))
39

40 1
  if (!all(where_rsplits)) {
41 1
    rlang::abort("Each element of `splits` must be an `rsplit` object.")
42
  }
43

44 1
  if (nrow(ids) != nrow(splits)) {
45 1
    rlang::abort("Split and ID vectors have different lengths.")
46
  }
47

48
  # Create another element to the splits that is a tibble containing
49
  # an identifier for each id column so that, in isolation, the resample
50
  # id can be known just based on the `rsplit` object. This can then be
51
  # accessed using the `labels` method for `rsplits`
52

53 1
  splits$splits <- map2(
54 1
    splits$splits,
55 1
    split_unnamed(ids, rlang::seq2(1L, nrow(ids))),
56 1
    add_id
57
  )
58

59 1
  res <- bind_cols(splits, ids)
60

61 1
  if (!is.null(attrib)) {
62 1
    if (any(names(attrib) == "")) {
63 1
      rlang::abort("`attrib` should be a fully named list.")
64
    }
65 1
    for (i in names(attrib)) {
66 1
      attr(res, i) <- attrib[[i]]
67
    }
68
  }
69

70 1
  if (length(subclass) > 0) {
71 1
    res <- add_class(res, cls = subclass, at_end = FALSE)
72
  }
73

74 1
  res
75
}
76

77
add_id <- function(split, id) {
78 1
  split$id <- id
79 1
  split
80
}
81

82
# ------------------------------------------------------------------------------
83

84
#' @export
85
`[.rset` <- function(x, i, j, drop = FALSE, ...) {
86 1
  out <- NextMethod()
87 1
  rset_reconstruct(out, x)
88
}
89

90
# ------------------------------------------------------------------------------
91

92
#' @export
93
`names<-.rset` <- function(x, value) {
94 1
  out <- NextMethod()
95 1
  rset_reconstruct(out, x)
96
}

Read our documentation on viewing source code .

Loading