R/import-standalone-forcats.R

In cardx: Extra Analysis Results Data Utilities

# Standalone file: do not edit by hand
# Source: https://github.com/insightsengineering/standalone/blob/HEAD/R/standalone-forcats.R
# Generated by: usethis::use_standalone("insightsengineering/standalone", "forcats")
# ----------------------------------------------------------------------
#
# ---
# repo: insightsengineering/standalone
# file: standalone-forcats.R
# last-updated: 2025-06-24
# license: https://unlicense.org
# imports:
# ---
#
# This file provides a minimal shim to provide a forcats-like API on top of
# base R functions. They are not drop-in replacements but allow a similar style
# of programming.
#
# ## Changelog
# 2025-06-24
#   - add `fct_collapse()` function (and its internal helper functions).
# 2025-05-03
#   - `add fct_relevel()` fix for non-factor inputs
# 2025-02-24
#   - `add fct_relevel()` function.
#
# nocov start
# styler: off

fct_infreq <- function(f, ordered = NA) {
  # reorder by frequency
  factor(
    f,
    levels = table(f) |> sort(decreasing = TRUE) |> names(),
    ordered = ifelse(is.na(ordered), is.ordered(f), ordered)
  )
}

fct_inorder <- function(f, ordered = NA) {
  factor(
    f,
    levels = stats::na.omit(unique(f)) |> union(levels(f)),
    ordered = ifelse(is.na(ordered), is.ordered(f), ordered)
  )
}

fct_rev <- function(f) {
  if (!inherits(f, "factor")) f <- factor(f)

  factor(
    f,
    levels = rev(levels(f)),
    ordered = is.ordered(f)
  )
}

fct_expand <- function(f, ..., after = Inf) {
  if (!inherits(f, "factor")) f <- factor(f)

  old_levels <- levels(f)
  new_levels <-
    old_levels |>
    append(values = setdiff(c(...), old_levels), after = after)
  factor(f, levels = new_levels)
}

fct_na_value_to_level <- function(f, level = NA) {
  if (!inherits(f, "factor")) f <- factor(f)

  # make NA an explicit level
  f <- addNA(f, ifany = FALSE)

  # replace NA level with the string passed in `level` argument
  if (!is.na(level)) levels(f)[is.na(levels(f))] <- level

  f
}


fct_relevel <- function(f, ..., after = 0L) {
  if (!inherits(f, "factor")) f <- as.factor(f)
  old_levels <- levels(f)
  # Handle re-leveling function or specified levels
  first_levels <- if (rlang::dots_n(...) == 1L && (is.function(..1) || rlang::is_formula(..1))) {
    fun <- rlang::as_function(..1)
    fun(old_levels)
  } else {
    rlang::chr(...)
  }

  # Reorder levels
  new_levels <- append(setdiff(old_levels, first_levels), first_levels, after = after)
  new_factor <- factor(f, levels = new_levels)
  return(new_factor)
}

# internal forcats function used within `fct_collapse()`
# to re-value factor levels
.lvls_revalue <- function(f, new_levels) {
  if (length(new_levels) != nlevels(f)) {
    n_new <- length(new_levels)
    n_old <- nlevels(f)
    cli::cli_abort("{.arg new_levels} must be the same length ({n_new}) as {.code levels(f)} ({n_old}).")
  }
  if (anyDuplicated(new_levels)) {
    u_levels <- unique(new_levels)
    index <- match(new_levels, u_levels)
    out <- index[f]
    attributes(out) <- attributes(f)
    attr(out, "levels") <- u_levels
    out
  } else {
    attr(f, "levels") <- new_levels
    f
  }
}

# internal forcats function used within `fct_collapse()`
# to rename factor levels
.lvls_rename <- function(f, new_levels) {
  old_levels <- levels(f)
  idx <- match(new_levels, old_levels)
  if (any(is.na(idx))) {
    bad <- new_levels[is.na(idx)]
    warning("Unknown levels in `f`: ", paste(bad, collapse = ", "), call. = FALSE)
    new_levels <- new_levels[!is.na(idx)]
    idx <- idx[!is.na(idx)]
  }
  old_levels[idx] <- names(new_levels)
  old_levels
}

# internal forcats function used within `fct_collapse()`
# to process other factor levels not being collapsed
.lvls_other <- function(f, keep, other_level = "Other") {
  if (all(keep)) {
    f
  } else {
    new_levels <- ifelse(keep, levels(f), other_level)
    f <- .lvls_revalue(f, new_levels)
    fct_relevel(f, other_level, after = Inf)
  }
}

fct_collapse <- function(f, ..., other_level = NULL) {
  if (!inherits(f, "factor")) f <- factor(f)

  dots <- rlang::list2(...)
  old <- unlist(dots, use.names = FALSE) %||% character()
  new <- rep(names(dots), lengths(dots))

  # collapse/re-value factor levels using new names
  out <- .lvls_revalue(f, .lvls_rename(f, rlang::set_names(old, new)))
  # add other levels not being collapsed
  if (!is.null(other_level)) out <- .lvls_other(out, levels(out) %in% new, other_level)

  out
}

# nocov end
# styler: on