1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
#' Reorder factor levels by hand
#'
#' This is a generalisation of [stats::relevel()] that allows you to move any
#' number of levels to any location.
#'
#' @param .f A factor (or character vector).
#' @param ... Either a function (or formula), or character levels.
#'
#' A function will be called with the current levels as input, and the
#' return value (which must be a character vector) will be used to relevel
#' the factor.
#'
#' Any levels not mentioned will be left in their existing order, by default
#' after the explicitly mentioned levels. Supports tidy dots.
#' @param after Where should the new values be placed?
#' @export
#' @examples
#' f <- factor(c("a", "b", "c", "d"), levels = c("b", "c", "d", "a"))
#' fct_relevel(f)
#' fct_relevel(f, "a")
#' fct_relevel(f, "b", "a")
#'
#' # Move to the third position
#' fct_relevel(f, "a", after = 2)
#'
#' # Relevel to the end
#' fct_relevel(f, "a", after = Inf)
#' fct_relevel(f, "a", after = 3)
#'
#' # Relevel with a function
#' fct_relevel(f, sort)
#' fct_relevel(f, sample)
#' fct_relevel(f, rev)
#'
#' # Using 'Inf' allows you to relevel to the end when the number
#' # of levels is unknown or variable (e.g. vectorised operations)
#' df <- forcats::gss_cat[, c("rincome", "denom")]
#' lapply(df, levels)
#'
#' df2 <- lapply(df, fct_relevel, "Don't know", after = Inf)
#' lapply(df2, levels)
#'
#' # You'll get a warning if the levels don't exist
#' fct_relevel(f, "e")
fct_relevel <- function(.f, ..., after = 0L) {
f <- check_factor(.f)
check_dots_unnamed()
old_levels <- levels(f)
if (dots_n(...) == 1L && (is.function(..1) || is_formula(..1))) {
fun <- as_function(..1)
first_levels <- fun(old_levels)
if (!is.character(first_levels)) {
cli::cli_abort("Re-leveling function must return character vector")
}
} else {
first_levels <- chr(...)
}
unknown <- setdiff(first_levels, old_levels)
if (length(unknown) > 0) {
cli::cli_warn("{length(unknown)} unknown level{?s} in `f`: {unknown}")
first_levels <- intersect(first_levels, old_levels)
}
new_levels <- append(setdiff(old_levels, first_levels), first_levels, after = after)
lvls_reorder(f, match(new_levels, old_levels))
}
|
