fct_regex_levels()

gistfile1.md

fct_regex_levels <- function(xs, patterns) {
  default_levels <- unique(xs)
  which_matches <- default_levels |> 
    lapply(stringr::str_which, patterns) |> 
    unlist()
  stopifnot(
    "Each factor level should have exactly one pattern" =
      all(seq_along(default_levels) %in% which_matches)
  )
  correct_order <- match(seq_along(default_levels), which_matches)
  factor(xs, default_levels[correct_order])
}

xs <- c("final (10)", "initial (18)", "medial (28)")
xs |> 
  factor() |> 
  levels()
#> [1] "final (10)"   "initial (18)" "medial (28)"

xs |> 
  fct_regex_levels(patterns = c("init", "medi", "fina")) |> 
  levels()
#> [1] "initial (18)" "medial (28)"  "final (10)"


library(testthat)
xs <- c("final (10)", "initial (18)", "medial (28)")
ys <- c("initial (18)", "medial (28)", "final (10)")
many_xs <- c(
  "medial (28)", "initial (18)", "medial (28)", "medial (28)", 
  "final (10)", "medial (28)", "medial (28)", "initial (18)", 
  "initial (18)", "initial (18)"
)


expect_levels <- function(object, expected, ...) {
  object |> 
    levels() |> 
    testthat::expect_equal(expected, ...)
}

should_work <- c("init", "medi", "final")
extra_regex <- c("ini", "med", "fin", "whatever") 

unmatched_level <- c("initial", "medial", "whatever") 
double_match <- c("ial", "final", "whatever") 

xs |> 
  fct_regex_levels(should_work) |> 
  expect_levels(ys)

xs |> 
  fct_regex_levels(extra_regex) |> 
  expect_levels(ys)

xs |> 
  fct_regex_levels(unmatched_level) |> 
  expect_error()

xs |> 
  fct_regex_levels(double_match) |> 
  expect_error()

many_xs |> 
  fct_regex_levels(should_work) |> 
  expect_levels(ys)

many_xs |> 
  fct_regex_levels(extra_regex) |> 
  expect_levels(ys)

many_xs |> 
  fct_regex_levels(unmatched_level) |> 
  expect_error()

many_xs |> 
  fct_regex_levels(double_match) |> 
  expect_error()

^{Created on 2024-03-08 with reprex v2.1.0}