diff --git a/R/import-standalone-checks.R b/R/import-standalone-checks.R index 7d94634d..72eb62a6 100644 --- a/R/import-standalone-checks.R +++ b/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 diff --git a/R/import-standalone-forcats.R b/R/import-standalone-forcats.R index 7d2d9a47..43c96cb5 100644 --- a/R/import-standalone-forcats.R +++ b/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)] } diff --git a/R/import-standalone-stringr.R b/R/import-standalone-stringr.R index b9b73f43..3a51d375 100644 --- a/R/import-standalone-stringr.R +++ b/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 diff --git a/R/import-standalone-tibble.R b/R/import-standalone-tibble.R index eaa12d0c..ff8c5aca 100644 --- a/R/import-standalone-tibble.R +++ b/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) }