R/import-standalone-stringr.R

In gtsummary: Presentation-Ready Data Summary and Analytic Result Tables

# Standalone file: do not edit by hand
# Source: https://github.com/insightsengineering/standalone/blob/HEAD/R/standalone-stringr.R
# Generated by: usethis::use_standalone("insightsengineering/standalone", "stringr")
# ----------------------------------------------------------------------
#
# ---
# repo: insightsengineering/standalone
# file: standalone-stringr.R
# last-updated: 2026-06-30
# license: https://unlicense.org
# imports: rlang
# ---
#
# This file provides a minimal shim to provide a stringr-like API on top of
# base R functions. They are not drop-in replacements but allow a similar style
# 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).
#
# nocov start
# styler: off

str_trim <- function(string, side = c("both", "left", "right")) {
  side <- rlang::arg_match(side)
  trimws(x = string, which = side, whitespace = "[ \t\r\n]")
}

str_squish <- function(string, fixed = FALSE, perl = !fixed) {
  string <- gsub("\\s+", " ", string, perl = perl)  # Replace multiple white spaces with a single white space
  string <- gsub("^\\s+|\\s+$", "", string, perl = perl)  # Trim leading and trailing white spaces
  return(string)
}

str_remove <- function(string, pattern, fixed = FALSE, perl = !fixed) {
  sub(x = string, pattern = pattern, replacement = "", fixed = fixed, perl = perl)
}

str_remove_all <- function(string, pattern, fixed = FALSE, perl = !fixed) {
  gsub(x = string, pattern = pattern, replacement = "", fixed = fixed, perl = perl)
}

str_extract <- function(string, pattern, fixed = FALSE, perl = !fixed) {
  res <- rep(NA_character_, length.out = length(string))
  res[str_detect(string, pattern, fixed = fixed)] <-
    regmatches(x = string, m = regexpr(pattern = pattern, text = string, fixed = fixed, perl = perl))

  res
}

str_extract_all <- function(string, pattern, fixed = FALSE, perl = !fixed) {
  regmatches(x = string, m = gregexpr(pattern = pattern, text = string, fixed = fixed, perl = perl))
}

str_detect <- function(string, pattern, fixed = FALSE, perl = !fixed) {
  grepl(pattern = pattern, x = string, fixed = fixed, perl = perl)
}

str_replace <- function(string, pattern, replacement, fixed = FALSE, perl = !fixed) {
  sub(x = string, pattern = pattern, replacement = replacement, fixed = fixed, perl = perl)
}

str_replace_all <- function(string, pattern, replacement, fixed = FALSE, perl = !fixed) {
  gsub(x = string, pattern = pattern, replacement = replacement, fixed = fixed, perl = perl)
}

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) {
  if (length(string) == 0L) return(character(0L))

  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)
}

str_sub_all <- function(string, start = 1L, end = -1L) {
  lapply(string, function(x) substr(x, start = start, stop = end))
}

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)
  }

  # 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 (is.infinite(n)) {
    return(strsplit(string, split = pattern, fixed = fixed, perl = perl))
  }

  # 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
# styler: on