From 336990f84ac6fde2598f5cf94d5119cb7894d631 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Thu, 13 Jun 2024 11:28:34 -0700 Subject: [PATCH] standalone updates --- R/import-standalone-checks.R | 104 ++++++++++++++---------- R/import-standalone-cli_call_env.R | 2 +- R/import-standalone-forcats.R | 36 ++++++++- R/import-standalone-stringr.R | 122 +++++++++++++++++++++++++---- R/import-standalone-tibble.R | 48 ++++++++++++ 5 files changed, 253 insertions(+), 59 deletions(-) create mode 100644 R/import-standalone-tibble.R diff --git a/R/import-standalone-checks.R b/R/import-standalone-checks.R index 88c255e3..0d4c4f7d 100644 --- a/R/import-standalone-checks.R +++ b/R/import-standalone-checks.R @@ -20,11 +20,11 @@ #' Check Class #' +#' @param x `(object)`\cr +#' object to check #' @param cls (`character`)\cr #' character vector or string indicating accepted classes. #' Passed to `inherits(what=cls)` -#' @param x `(object)`\cr -#' object to check #' @param message (`character`)\cr #' string passed to `cli::cli_abort(message)` #' @param allow_empty (`logical(1)`)\cr @@ -33,6 +33,9 @@ #' @param arg_name (`string`)\cr #' string indicating the label/symbol of the object being checked. #' Default is `rlang::caller_arg(x)` +#' @param envir (`environment`)\cr +#' Environment to evaluate the glue expressions in passed in `cli::cli_abort(message)`. +#' Default is `rlang::current_env()` #' @inheritParams cli::cli_abort #' @inheritParams rlang::abort #' @keywords internal @@ -50,14 +53,15 @@ check_class <- function(x, ), arg_name = rlang::caller_arg(x), class = "check_class", - call = get_cli_abort_call()) { + call = get_cli_abort_call(), + envir = rlang::current_env()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { return(invisible(x)) } if (!inherits(x, cls)) { - cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } invisible(x) } @@ -73,16 +77,17 @@ check_data_frame <- function(x, ifelse( allow_empty, "The {.arg {arg_name}} argument must be class - {.cls {cls}} or empty, not {.obj_type_friendly {x}}.", + {.cls data.frame} or empty, not {.obj_type_friendly {x}}.", "The {.arg {arg_name}} argument must be class - {.cls {cls}}, not {.obj_type_friendly {x}}." + {.cls data.frame}, not {.obj_type_friendly {x}}." ), arg_name = rlang::caller_arg(x), class = "check_data_frame", - call = get_cli_abort_call()) { + call = get_cli_abort_call(), + envir = rlang::current_env()) { check_class( x = x, cls = "data.frame", allow_empty = allow_empty, - message = message, arg_name = arg_name, class = class, call = call + message = message, arg_name = arg_name, class = class, call = call, envir = envir ) } @@ -97,16 +102,17 @@ check_logical <- function(x, ifelse( allow_empty, "The {.arg {arg_name}} argument must be class - {.cls {cls}} or empty, not {.obj_type_friendly {x}}.", + {.cls logical} or empty, not {.obj_type_friendly {x}}.", "The {.arg {arg_name}} argument must be class - {.cls {cls}}, not {.obj_type_friendly {x}}." + {.cls logical}, not {.obj_type_friendly {x}}." ), arg_name = rlang::caller_arg(x), class = "check_logical", - call = get_cli_abort_call()) { + call = get_cli_abort_call(), + envir = rlang::current_env()) { check_class( x = x, cls = "logical", allow_empty = allow_empty, - message = message, arg_name = arg_name, class = class, call = call + message = message, arg_name = arg_name, class = class, call = call, envir = envir ) } @@ -121,23 +127,24 @@ check_scalar_logical <- function(x, ifelse( allow_empty, "The {.arg {arg_name}} argument must be a scalar with class - {.cls {cls}} or empty, not {.obj_type_friendly {x}}.", + {.cls logical} or empty, not {.obj_type_friendly {x}}.", "The {.arg {arg_name}} argument must be a scalar with class - {.cls {cls}}, not {.obj_type_friendly {x}}." + {.cls logical}, not {.obj_type_friendly {x}}." ), arg_name = rlang::caller_arg(x), class = "check_scalar_logical", - call = get_cli_abort_call()) { + call = get_cli_abort_call(), + envir = rlang::current_env()) { check_logical( x = x, allow_empty = allow_empty, message = message, arg_name = arg_name, - class = class, call = call + class = class, call = call, envir = envir ) check_scalar( x = x, allow_empty = allow_empty, message = message, arg_name = arg_name, - call = call + call = call, envir = envir ) } @@ -158,17 +165,18 @@ check_string <- function(x, ), arg_name = rlang::caller_arg(x), class = "check_string", - call = get_cli_abort_call()) { + call = get_cli_abort_call(), + envir = rlang::current_env()) { check_class( x = x, cls = "character", allow_empty = allow_empty, message = message, arg_name = arg_name, - class = class, call = call + class = class, call = call, envir = envir ) check_scalar( x = x, allow_empty = allow_empty, message = message, arg_name = arg_name, - class = class, call = call + class = class, call = call, envir = envir ) } @@ -181,9 +189,10 @@ check_not_missing <- function(x, message = "The {.arg {arg_name}} argument cannot be missing.", arg_name = rlang::caller_arg(x), class = "check_not_missing", - call = get_cli_abort_call()) { + call = get_cli_abort_call(), + envir = rlang::current_env()) { if (missing(x)) { - cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } # can't return 'x' because it may be an unevaluable obj, eg a bare tidyselect @@ -197,7 +206,8 @@ check_not_missing <- function(x, #' @inheritParams check_class #' @keywords internal #' @noRd -check_length <- function(x, length, +check_length <- function(x, + length, message = ifelse( allow_empty, @@ -207,7 +217,8 @@ check_length <- function(x, length, allow_empty = FALSE, arg_name = rlang::caller_arg(x), class = "check_length", - call = get_cli_abort_call()) { + call = get_cli_abort_call(), + envir = rlang::current_env()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { return(invisible(x)) @@ -215,7 +226,7 @@ check_length <- function(x, length, # check length if (length(x) != length) { - cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } invisible(x) @@ -231,16 +242,17 @@ check_scalar <- function(x, message = ifelse( allow_empty, - "The {.arg {arg_name}} argument must be length {.val {length}} or empty.", - "The {.arg {arg_name}} argument must be length {.val {length}}." + "The {.arg {arg_name}} argument must be length {.val {1}} or empty.", + "The {.arg {arg_name}} argument must be length {.val {1}}." ), arg_name = rlang::caller_arg(x), class = "check_scalar", - call = get_cli_abort_call()) { + call = get_cli_abort_call(), + envir = rlang::current_env()) { check_length( x = x, length = 1L, message = message, allow_empty = allow_empty, arg_name = arg_name, - class = class, call = call + class = class, call = call, envir = envir ) } @@ -253,15 +265,16 @@ check_scalar <- function(x, check_n_levels <- function(x, n_levels, message = - "The {.arg {arg_name}} argument must have {.val {length}} levels.", + "The {.arg {arg_name}} argument must have {.val {n_levels}} levels.", arg_name = rlang::caller_arg(x), class = "check_n_levels", - call = get_cli_abort_call()) { + call = get_cli_abort_call(), + envir = rlang::current_env()) { check_length( x = stats::na.omit(x) |> unique(), length = n_levels, message = message, allow_empty = FALSE, arg_name = arg_name, - class = class, call = call + class = class, call = call, envir = envir ) } @@ -286,7 +299,8 @@ check_range <- function(x, allow_empty = FALSE, arg_name = rlang::caller_arg(x), class = "check_range", - call = get_cli_abort_call()) { + call = get_cli_abort_call(), + envir = rlang::current_env()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { return(invisible(x)) @@ -316,7 +330,7 @@ check_range <- function(x, # print error if (print_error) { - cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } invisible(x) @@ -344,13 +358,14 @@ check_scalar_range <- function(x, and length {.val {1}}.", arg_name = rlang::caller_arg(x), class = "check_scalar_range", - call = get_cli_abort_call()) { + call = get_cli_abort_call(), + envir = rlang::current_env()) { check_scalar(x, message = message, arg_name = arg_name, - allow_empty = allow_empty, class = class, call = call) + allow_empty = allow_empty, class = class, call = call, envir = envir) check_range(x = x, range = range, include_bounds = include_bounds, message = message, allow_empty = allow_empty, - arg_name = arg_name, class = class, call = call) + arg_name = arg_name, class = class, call = call, envir = envir) } #' Check Binary @@ -377,7 +392,8 @@ check_binary <- function(x, ), arg_name = rlang::caller_arg(x), class = "check_binary", - call = get_cli_abort_call()) { + call = get_cli_abort_call(), + envir = rlang::current_env()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { return(invisible(x)) @@ -385,11 +401,12 @@ check_binary <- function(x, # first check x is either logical or numeric check_class(x, cls = c("logical", "numeric", "integer"), - arg_name = arg_name, message = message, class = class, call = call) + arg_name = arg_name, message = message, class = class, + call = call, envir = envir) # if "numeric" or "integer", it must be coded as 0, 1 if (!is.logical(x) && !(rlang::is_integerish(x) && rlang::is_empty(setdiff(x, c(0, 1, NA))))) { - cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } invisible(x) @@ -420,7 +437,8 @@ check_formula_list_selector <- function(x, ), arg_name = rlang::caller_arg(x), class = "check_formula_list_selector", - call = get_cli_abort_call()) { + call = get_cli_abort_call(), + envir = rlang::current_env()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { return(invisible(x)) @@ -429,14 +447,14 @@ check_formula_list_selector <- function(x, # first check the general structure; must be a list or formula check_class( x = x, cls = c("list", "formula"), allow_empty = allow_empty, - message = message, arg_name = arg_name, class = class, call = call + message = message, arg_name = arg_name, class = class, call = call, envir = envir ) # if it's a list, then check each element is either named or a formula if (inherits(x, "list")) { for (i in seq_along(x)) { if (!rlang::is_named(x[i]) && !inherits(x[[i]], "formula")) { - cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } } } diff --git a/R/import-standalone-cli_call_env.R b/R/import-standalone-cli_call_env.R index 88ccd693..dc90d64c 100644 --- a/R/import-standalone-cli_call_env.R +++ b/R/import-standalone-cli_call_env.R @@ -33,7 +33,7 @@ set_cli_abort_call <- function(env = rlang::caller_env()) { if (getOption("cli_abort_call") |> is.null()) { options(cli_abort_call = env) set_call <- as.call(list(function() options(cli_abort_call = NULL))) - do.call(on.exit, list(expr = set_call, after = FALSE), envir = env) + do.call(on.exit, list(expr = set_call, add = TRUE, after = FALSE), envir = env) } invisible() } diff --git a/R/import-standalone-forcats.R b/R/import-standalone-forcats.R index db001fd9..6da3a6ea 100644 --- a/R/import-standalone-forcats.R +++ b/R/import-standalone-forcats.R @@ -4,7 +4,7 @@ # # --- # file: standalone-forcats.R -# last-updated: 2024-01-24 +# last-updated: 2024-06-05 # license: https://unlicense.org # imports: # --- @@ -35,5 +35,39 @@ fct_inorder <- function(f, ordered = NA) { ) } +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 +} + + + # nocov end # styler: on diff --git a/R/import-standalone-stringr.R b/R/import-standalone-stringr.R index 263bde5b..9c243995 100644 --- a/R/import-standalone-stringr.R +++ b/R/import-standalone-stringr.R @@ -4,7 +4,7 @@ # # --- # file: standalone-stringr.R -# last-updated: 2024-01-24 +# last-updated: 2024-06-05 # license: https://unlicense.org # imports: rlang # --- @@ -23,25 +23,119 @@ str_trim <- function(string, side = c("both", "left", "right")) { trimws(x = string, which = side, whitespace = "[ \t\r\n]") } -str_squish <- function(string) { - gsub(x = string, pattern = "\\s+", replacement = " ") |> - str_trim(side = "both") +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_all <- function(string, pattern) { - gsub(x = string, pattern = pattern, replacement = "") +str_remove <- function (string, pattern, fixed = FALSE, perl = !fixed) { + sub (x = string, pattern = pattern, replacement = "", fixed = fixed, perl = perl) } -str_extract <- function(string, pattern) { - ifelse( - str_detect(string, pattern), - regmatches(x = string, m = regexpr(pattern = pattern, text = string)), - NA_character_ - ) +str_remove_all <- function(string, pattern, fixed = FALSE, perl = !fixed) { + gsub(x = string, pattern = pattern, replacement = "", fixed = fixed, perl = perl) } -str_detect <- function(string, pattern) { - grepl(pattern = pattern, x = string) +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, 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)) + } +} + +str_sub <- function(string, start = 1L, end = -1L){ + str_length <- nchar(string) + + # Adjust start and end indices for negative values + if (start < 0) { + start <- str_length + start + 1 + } + if (end < 0) { + end <- str_length + end + 1 + } + + 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, c("left", "right", "both")) + + if (side == "both") { + pad_left <- (width - nchar(string)) %/% 2 + pad_right <- width - nchar(string) - pad_left + padded_string <- paste0(strrep(pad, pad_left), string, strrep(pad, pad_right)) + } else { + format_string <- ifelse(side == "right", paste0("%-", width, "s"), + ifelse(side == "left", paste0("%", width, "s"), + paste0("%", width, "s"))) + + padded_string <- sprintf(format_string, string) + } + + return(padded_string) +} + +str_split <- function(string, pattern, n = Inf, fixed = FALSE, perl = !fixed) { + if (n == Inf) { + 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) + }) + } } # nocov end diff --git a/R/import-standalone-tibble.R b/R/import-standalone-tibble.R new file mode 100644 index 00000000..f4c7b001 --- /dev/null +++ b/R/import-standalone-tibble.R @@ -0,0 +1,48 @@ +# Standalone file: do not edit by hand +# Source: +# ---------------------------------------------------------------------- +# +# --- +# file: standalone-tibble.R +# last-updated: 2024-05-07 +# license: https://unlicense.org +# imports: [dplyr] +# --- +# +# This file provides a minimal shim to provide a tibble-like API on top of +# base R functions. They are not drop-in replacements but allow a similar style +# of programming. +# +# ## Changelog +# +# nocov start +# styler: off + +deframe <- function(x) { + if (ncol(x) == 1L) return(x[[1]]) + x[[2]] |> stats::setNames(x[[1]]) +} + +enframe <- function(x, name = "name", value = "value") { + if (!is.null(names(x))) { + lst <- list(names(x), unname(x)) |> stats::setNames(c(name, value)) + } + else { + lst <- list(seq_along(x), unname(x)) |> stats::setNames(c(name, value)) + } + dplyr::tibble(!!!lst) +} + +remove_rownames <- function(.data) { + rownames(.data) <- NULL + .data +} + +rownames_to_column <- function(.data, var = "rowname") { + .data[[var]] <- rownames(.data) + + dplyr::relocate(.data, dplyr::all_of(var), .before = 1L) +} + +# nocov end +# styler: on