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
  if (nrow(ids) != nrow(splits)) {
39 1
    rlang::abort("Split and ID vectors have different lengths.")
40
  }
41

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

47 1
  splits$splits <- map2(
48 1
    splits$splits,
49 1
    split_unnamed(ids, rlang::seq2(1L, nrow(ids))),
50 1
    add_id
51
  )
52

53 1
  res <- bind_cols(splits, ids)
54

55 1
  if (!is.null(attrib)) {
56 1
    if (any(names(attrib) == "")) {
57 1
      rlang::abort("`attrib` should be a fully named list.")
58
    }
59 1
    for (i in names(attrib)) {
60 1
      attr(res, i) <- attrib[[i]]
61
    }
62
  }
63

64 1
  if (length(subclass) > 0) {
65 1
    res <- add_class(res, cls = subclass, at_end = FALSE)
66
  }
67

68 1
  res
69
}
70

71
add_id <- function(split, id) {
72 1
  split$id <- id
73 1
  split
74
}
75

76
# ------------------------------------------------------------------------------
77

78
#' @export
79
`[.rset` <- function(x, i, j, drop = FALSE, ...) {
80 1
  out <- NextMethod()
81 1
  rset_reconstruct(out, x)
82
}
83

84
# ------------------------------------------------------------------------------
85

86
#' @export
87
`names<-.rset` <- function(x, value) {
88 1
  out <- NextMethod()
89 1
  rset_reconstruct(out, x)
90
}

Read our documentation on viewing source code .

Loading