Skip to content

Instantly share code, notes, and snippets.

@RLesur
Last active October 31, 2023 23:48
Show Gist options
  • Star 2 You must be signed in to star a gist
  • Fork 1 You must be signed in to fork a gist
  • Save RLesur/4abbb52c2b1403f85625b7e3675b22c3 to your computer and use it in GitHub Desktop.
Save RLesur/4abbb52c2b1403f85625b7e3675b22c3 to your computer and use it in GitHub Desktop.
How to create reusable dplyr::case_when() functions?
# case_when factory: ----------------------------------------------
create_case_when <- function(..., vars = "x") {
fun_fmls <- purrr::map(rlang::set_names(vars), ~ rlang::missing_arg())
fun_body <- substitute({
for (name in var) {
symb <- rlang::eval_bare(rlang::sym(name))
var <- rlang::eval_tidy(rlang::enquo(symb))
assign(name, var)
}
forms <- purrr::map(formulas, rlang::`f_env<-`, value = environment())
do.call(dplyr::case_when, forms)
})
formulas <- rlang::dots_list(...)
var <- vars
structure(
rlang::new_function(fun_fmls, fun_body),
class = c("case_when", "function")
)
}
formulas <- function(x, ...) UseMethod("formulas")
formulas.case_when <- function(x, ...) get("formulas", envir = environment(x))
print.case_when <- function(x, ...) {
formulas <- formulas(x)
n <- length(formulas)
out <- capture.output(purrr::walk(formulas, print, showEnv = FALSE))
out <- c(crayon::cyan("<CASE WHEN>"),
crayon::magenta(paste(n, "conditions:")),
crayon::green(paste("->", out)), "")
cat(paste0(out, collapse = "\n"))
invisible(x)
}
# Applications -----------------------------------------------------------
# One-dimension case_when() ----------------------------------------------
library(dplyr)
people <-
tribble(
~name, ~sex, ~seek,
"Henry", "M", "F",
"Mary", "F", "M",
)
cw_sex <- create_case_when(x == "F" ~ "Woman",
x == "M" ~ "Man",
TRUE ~ as.character(x),
vars = c("x"))
print(cw_sex)
people %>% mutate(sex_label = cw_sex(sex), seek_label = cw_sex(seek))
# Two-dimensions case_when() ----------------------------------------------
people2 <-
tribble(
~name, ~sex, ~lang,
"Henry", "M", "en",
"Mary", "F", "en",
"Jacques", "M", "fr",
"Mireille", "F", "fr"
)
cw_sex2 <- create_case_when(x == "F" & y == "en" ~ "Woman",
x == "F" & y == "fr" ~ "Femme",
x == "M" & y == "en" ~ "Man",
x == "M" & y == "fr" ~ "Homme",
TRUE ~ as.character(x),
vars = c("x", "y"))
print(cw_sex2)
people2 %>% mutate(sex_label = cw_sex2(sex, lang))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment