Update imported {standalone} scripts to current source (#280)

R/import-standalone-checks.R

@@ -6,7 +6,7 @@
 # ---
 # repo: insightsengineering/standalone
 # file: standalone-checks.R
-# last-updated: 2024-05-04
+# last-updated: 2025-05-08
 # license: https://unlicense.org
 # dependencies: standalone-cli_call_env.R
 # imports: [rlang, cli]
@@ -16,6 +16,12 @@
 # passed by users to functions in packages.
 #
 # ## Changelog
+#
+# 2025-05-08
+#   - Added `check_identical()` and `check_identical_length()`
+# 2025-04-27
+#   - Added `check_named()`
+
 # nocov start
 # styler: off
 
@@ -604,5 +610,70 @@ check_numeric <- function(x,
   invisible(x)
 }
 
+#' Check is Named
+#'
+#' @inheritParams check_numeric
+#' @keywords internal
+#' @noRd
+check_named <- function(x,
+                        allow_empty = FALSE,
+                        message = "The {.arg {arg_name}} argument must be named.",
+                        arg_name = rlang::caller_arg(x),
+                        call = get_cli_abort_call(),
+                        envir = rlang::current_env()) {
+  # if empty and allowed, return input invisibly
+  if (allow_empty && rlang::is_empty(x)) {
+    return(invisible(x))
+  }
+
+  # check input is named
+  if (!rlang::is_named(x)) {
+    cli::cli_abort(message = message, call = call, .envir = envir)
+  }
+
+  invisible(x)
+}
+
+#' Check is Identical
+#'
+#' @inheritParams check_numeric
+#' @keywords internal
+#' @noRd
+check_identical <- function(x, y,
+                            message = "Arguments {.arg {arg_name_x}} and {.arg {arg_name_y}} must be identical.",
+                            arg_name_x = rlang::caller_arg(x),
+                            arg_name_y = rlang::caller_arg(y),
+                            call = get_cli_abort_call(),
+                            envir = rlang::current_env()) {
+  if (!identical(x, y)) {
+    cli::cli_abort(message = message, call = call, .envir = envir)
+  }
+
+  invisible()
+}
+
+
+#' Check Identical Length
+#'
+#' @inheritParams check_numeric
+#' @keywords internal
+#' @noRd
+check_identical_length <- function(x, y,
+                                   message = "Arguments {.arg {arg_name_x}} and {.arg {arg_name_y}} must be the same length.",
+                                   arg_name_x = rlang::caller_arg(x),
+                                   arg_name_y = rlang::caller_arg(y),
+                                   call = get_cli_abort_call(),
+                                   envir = rlang::current_env()) {
+  check_identical(
+    x = length(x),
+    y = length(y),
+    message = message,
+    arg_name_x = arg_name_x,
+    arg_name_y = arg_name_y,
+    call = call,
+    envir = envir
+  )
+}
+
 # nocov end
 # styler: on

R/import-standalone-forcats.R

@@ -6,7 +6,7 @@
 # ---
 # repo: insightsengineering/standalone
 # file: standalone-forcats.R
-# last-updated: 2025-07-25
+# last-updated: 2026-06-30
 # license: https://unlicense.org
 # imports:
 # ---
@@ -16,6 +16,12 @@
 # of programming.
 #
 # ## Changelog
+# 2026-06-30
+#   - `fct_collapse()` no longer relies on the base R `%||%` operator, which is
+#     only available in R >= 4.4.
+#   - `fct_reorder()` partitions values with a single `split()` call instead of
+#     scanning the full vector once per level (large speed/memory improvement
+#     for factors with many levels).
 # 2025-07-25
 #   - add `fct_reorder()` function.
 # 2025-06-24
@@ -147,7 +153,8 @@ fct_collapse <- function(f, ..., other_level = NULL) {
   if (!inherits(f, "factor")) f <- factor(f)
 
   dots <- rlang::list2(...)
-  old <- unlist(dots, use.names = FALSE) %||% character()
+  old <- unlist(dots, use.names = FALSE)
+  if (is.null(old)) old <- character()
   new <- rep(names(dots), lengths(dots))
 
   # collapse/re-value factor levels using new names
@@ -165,9 +172,13 @@ fct_reorder <- function(.f, .x, .fun = stats::median, ..., .na_rm = NULL, .defau
 
   lvls <- levels(.f)
 
+  # Partition `.x` by level in a single pass (O(n)) instead of re-scanning the
+  # whole vector once per level (O(n * nlevels)).
+  groups <- split(.x, .f)
+
   # Compute summary statistic per level
   summary_vals <- vapply(lvls, function(lvl) {
-    vals <- .x[.f == lvl]
+    vals <- groups[[lvl]]
     if (isTRUE(.na_rm)) {
       vals <- vals[!is.na(vals)]
     }

R/import-standalone-stringr.R

@@ -6,7 +6,7 @@
 # ---
 # repo: insightsengineering/standalone
 # file: standalone-stringr.R
-# last-updated: 2024-11-01
+# last-updated: 2026-06-30
 # license: https://unlicense.org
 # imports: rlang
 # ---
@@ -16,6 +16,15 @@
 # of programming.
 #
 # ## Changelog
+# 2026-06-30
+#   - `str_pad()` now vectorizes over `width`/`pad`, treats `width` smaller than
+#     the string as a no-op (instead of erroring), preserves `NA`, and returns
+#     `character(0)` for empty input.
+#   - `str_sub()` now supports vectorized `start`/`end`.
+#   - `str_split()` with finite `n` keeps the original tail substring instead of
+#     re-joining with the literal `pattern` (fixes regex separators).
+#   - `word()` keeps empty segments, returns `NA_character_` for `NA`/out-of-range
+#     input, and is vectorized via `vapply()`.
 # 2024-11-01
 #   - `str_pad()` was updated to use `strrep()` instead of `sprintf()` (accommodates escape characters).
 #
@@ -65,43 +74,42 @@ str_replace_all <- function(string, pattern, replacement, fixed = FALSE, perl =
   gsub(x = string, pattern = pattern, replacement = replacement, fixed = fixed, perl = perl)
 }
 
-word <- function(string, start, end = start, sep = " ", fixed = TRUE, perl = !fixed) {
-  # Handle vectorized string input
-  if (length(string) > 1) {
-    return(sapply(string, word, start, end, sep, fixed, USE.NAMES = FALSE))
-  }
-
-  words <- unlist(strsplit(string, split = sep, fixed = fixed, perl = perl))
-  words <- words[words != ""]  # Remove empty strings
-
-  # Adjust negative indices
-  n <- length(words)
-  if (start < 0) {
-    start <- n + start + 1
-  }
-  if (end < 0) {
-    end <- n + end + 1
-  }
-
-  # Validate indices
-  if (start < 1 || end > n || start > end) {
-    return(NA)
-  } else {
-    extracted_words <- words[start:end]
-    return(paste(extracted_words, collapse = sep))
-  }
+word <- function(string, start = 1L, end = start, sep = " ", fixed = TRUE, perl = !fixed) {
+  vapply(
+    string,
+    function(s) {
+      if (is.na(s)) return(NA_character_)
+      words <- strsplit(s, split = sep, fixed = fixed, perl = perl)[[1]]
+      # an empty string yields a single empty word (matches stringr); empty
+      # segments from consecutive separators are kept (not dropped)
+      if (length(words) == 0L) words <- ""
+
+      n <- length(words)
+      start_i <- if (start < 0) n + start + 1L else start
+      end_i <- if (end < 0) n + end + 1L else end
+
+      if (start_i < 1L || end_i > n || start_i > end_i) {
+        return(NA_character_)
+      }
+      paste(words[start_i:end_i], collapse = sep)
+    },
+    character(1L),
+    USE.NAMES = FALSE
+  )
 }
 
 str_sub <- function(string, start = 1L, end = -1L) {
-  str_length <- nchar(string)
+  if (length(string) == 0L) return(character(0L))
 
-  # Adjust start and end indices for negative values
-  if (start < 0) {
-    start <- str_length + start + 1
-  }
-  if (end < 0) {
-    end <- str_length + end + 1
-  }
+  n <- max(length(string), length(start), length(end))
+  string <- rep_len(string, n)
+  start <- rep_len(start, n)
+  end <- rep_len(end, n)
+
+  str_length <- nchar(string)
+  # Adjust start and end indices for negative values (vectorized)
+  start <- ifelse(start < 0, str_length + start + 1L, start)
+  end <- ifelse(end < 0, str_length + end + 1L, end)
 
   substr(x = string, start = start, stop = end)
 }
@@ -112,40 +120,53 @@ str_sub_all <- function(string, start = 1L, end = -1L) {
 
 str_pad <- function(string, width, side = c("left", "right", "both"), pad = " ", use_width = TRUE) {
   side <- match.arg(side)
+  if (length(string) == 0L) return(character(0L))
+
+  # recycle inputs so width/pad can vary per element
+  n <- max(length(string), length(width), length(pad))
+  string <- rep_len(string, n)
+  width <- rep_len(width, n)
+  pad <- rep_len(pad, n)
+
+  current_length <- nchar(string)
+  # never pad to fewer than the existing characters (matches stringr no-op)
+  pad_length <- pmax(width - current_length, 0L)
+
+  if (side == "both") {
+    pad_left <- pad_length %/% 2L
+    pad_right <- pad_length - pad_left
+    out <- paste0(strrep(pad, pad_left), string, strrep(pad, pad_right))
+  } else if (side == "right") {
+    out <- paste0(string, strrep(pad, pad_length))
+  } else { # side == "left"
+    out <- paste0(strrep(pad, pad_length), string)
+  }
 
-  # allow vectorized input
-  padded_strings <- sapply(string, function(s) {
-    current_length <- nchar(s)
-    pad_length <- width - current_length
-
-    if (side == "both") {
-      pad_left <- pad_length %/% 2
-      pad_right <- pad_length - pad_left
-      padded_string <- paste0(strrep(pad, pad_left), s, strrep(pad, pad_right))
-    } else if (side == "right") {
-      padded_string <- paste0(s, strrep(pad, pad_length))
-    } else { # side == "left"
-      padded_string <- paste0(strrep(pad, pad_length), s)
-    }
-
-    return(padded_string)
-  })
-
-  return(unname(padded_strings))
+  # preserve NA inputs rather than turning them into the string "NA"
+  out[is.na(string)] <- NA_character_
+  out
 }
 
 str_split <- function(string, pattern, n = Inf, fixed = FALSE, perl = !fixed) {
-  if (n == Inf) {
+  if (is.infinite(n)) {
     return(strsplit(string, split = pattern, fixed = fixed, perl = perl))
-  } else {
-    parts <- strsplit(string, split = pattern, fixed = fixed, perl = perl)
-    lapply(parts, function(x) {
-      if (length(x) > n) {
-        x <- c(x[1:(n - 1)], paste(x[n:length(x)], collapse = pattern))
-      }
-      return(x)
-    })
   }
+
+  # For finite n, split on only the first (n - 1) matches so the final piece
+  # keeps the original remaining substring (including any separators) rather
+  # than re-joining the tail with the literal `pattern`.
+  lapply(string, function(s) {
+    if (is.na(s)) return(NA_character_)
+    full <- strsplit(s, split = pattern, fixed = fixed, perl = perl)[[1]]
+    if (n <= 1L || length(full) <= n) {
+      return(if (n <= 1L) s else full)
+    }
+
+    m <- gregexpr(pattern = pattern, text = s, fixed = fixed, perl = perl)[[1]]
+    # position just past the (n - 1)th separator marks the start of the tail
+    cut_at <- m[n - 1L] + attr(m, "match.length")[n - 1L]
+    c(full[seq_len(n - 1L)], substring(s, cut_at))
+  })
 }
 
 # nocov end

R/import-standalone-tibble.R

@@ -6,7 +6,7 @@
 # ---
 # repo: insightsengineering/standalone
 # file: standalone-tibble.R
-# last-updated: 2024-05-07
+# last-updated: 2026-06-30
 # license: https://unlicense.org
 # imports: [dplyr]
 # ---
@@ -16,6 +16,10 @@
 # of programming.
 #
 # ## Changelog
+# 2026-06-30
+#   - `enframe()` now handles `NULL` input and `name = NULL` (value-only output).
+#   - `rownames_to_column()` resets to default integer row names, matching
+#     `tibble::rownames_to_column()`.
 #
 # nocov start
 # styler: off
@@ -26,10 +30,14 @@ deframe <- function(x) {
 }
 
 enframe <- function(x, name = "name", value = "value") {
-  if (!is.null(names(x))) {
+  if (is.null(x)) x <- logical()
+
+  if (is.null(name)) {
+    # value-only tibble; ignore any names on `x`
+    lst <- list(unname(x)) |> stats::setNames(value)
+  } else if (!is.null(names(x))) {
     lst <- list(names(x), unname(x)) |> stats::setNames(c(name, value))
-  }
-  else {
+  } else {
     lst <- list(seq_along(x), unname(x)) |> stats::setNames(c(name, value))
   }
   dplyr::tibble(!!!lst)
@@ -41,7 +49,10 @@ remove_rownames <- function(.data) {
 }
 
 rownames_to_column <- function(.data, var = "rowname") {
-  .data[[var]] <- rownames(.data)
+  col <- rownames(.data)
+  # reset to default integer row names, matching tibble::rownames_to_column()
+  rownames(.data) <- NULL
+  .data[[var]] <- col
 
   dplyr::relocate(.data, dplyr::all_of(var), .before = 1L)
 }