1#' Low-level functions for manipulating levels
2#'
3#' `lvls_reorder` leaves values as they are, but changes the order.
4#' `lvls_revalue` changes the values of existing levels; there must
5#' be one new level for each old level.
6#' `lvls_expand` expands the set of levels; the new levels must
7#' include the old levels.
8#'
9#' These functions are less helpful than the higher-level `fct_` functions,
10#' but are safer than the very low-level manipulation of levels directly,
11#' because they are more specific, and hence can more carefully check their
12#' arguments.
13#'
14#' @param f A factor (or character vector).
15#' @param idx A integer index, with one integer for each existing level.
16#' @param new_levels A character vector of new levels.
17#' @param ordered A logical which determines the "ordered" status of the
18#'   output factor. `NA` preserves the existing status of the factor.
19#' @name lvls
20#' @examples
21#' f <- factor(c("a", "b", "c"))
22#' lvls_reorder(f, 3:1)
23#' lvls_revalue(f, c("apple", "banana", "carrot"))
24#' lvls_expand(f, c("a", "b", "c", "d"))
25NULL
26
27#' @export
28#' @rdname lvls
29lvls_reorder <- function(f, idx, ordered = NA) {
30  f <- check_factor(f)
31  if (!is.numeric(idx)) {
32    stop("`idx` must be numeric", call. = FALSE)
33  }
34  if (!setequal(idx, lvls_seq(f)) || length(idx) != nlevels(f)) {
35    stop("`idx` must contain one integer for each level of `f`", call. = FALSE)
36  }
37
38  refactor(f, levels(f)[idx], ordered = ordered)
39}
40
41#' @export
42#' @rdname lvls
43lvls_revalue <- function(f, new_levels) {
44  f <- check_factor(f)
45
46  if (!is.character(new_levels)) {
47    stop("`new_levels` must be a character vector", call. = FALSE)
48  }
49
50  if (length(new_levels) != nlevels(f)) {
51    stop(
52      "`new_levels` must be the same length as `levels(f)`: expected ",
53      nlevels(f), " new levels, got ", length(new_levels), ".",
54      call. = FALSE
55    )
56  }
57
58  if (anyDuplicated(new_levels)) {
59    # Collapse levels, creating a new factor
60    u_levels <- unique(new_levels)
61    index <- match(new_levels, u_levels)
62
63    out <- index[f]
64    attributes(out) <- attributes(f)
65    attr(out, "levels") <- u_levels
66    out
67  } else {
68    attr(f, "levels") <- new_levels
69    f
70  }
71}
72
73#' @export
74#' @rdname lvls
75lvls_expand <- function(f, new_levels) {
76  f <- check_factor(f)
77
78  missing <- setdiff(levels(f), new_levels)
79  if (length(missing) > 0) {
80    stop(
81      "Must include all existing levels. Missing: ", paste0(missing, collapse = ", "),
82      call. = FALSE)
83  }
84
85  refactor(f, new_levels)
86}
87
88lvls_seq <- function(f) {
89  seq_along(levels(f))
90}
91
92refactor <- function(f, new_levels, ordered = NA) {
93  if (is.na(ordered)) {
94    ordered <- is.ordered(f)
95  }
96
97  new_f <- factor(f, levels = new_levels, exclude = NULL, ordered = ordered)
98  attributes(new_f) <- utils::modifyList(attributes(f), attributes(new_f))
99  new_f
100}
101
102
103#' Find all levels in a list of factors
104#'
105#' @param fs A list of factors.
106#' @export
107#' @examples
108#' fs <- list(factor("a"), factor("b"), factor(c("a", "b")))
109#' lvls_union(fs)
110lvls_union <- function(fs) {
111  fs <- check_factor_list(fs)
112  Reduce(function(x, y) union(x, levels(y)), fs, init = character())
113}
114