From e7a54862ab51da1d81bbce0453eb2f7698d3f25e Mon Sep 17 00:00:00 2001 From: Nan Xiao Date: Tue, 20 Feb 2024 21:59:40 -0500 Subject: [PATCH] Replace glue with gluestick --- DESCRIPTION | 2 +- LICENSES_THIRD_PARTY | 4 ++-- R/adam_mapping.R | 6 +++--- R/collect.R | 2 +- R/collect_n_subject.R | 20 ++++++++++---------- R/outdata.R | 8 ++++---- R/utility.R | 44 ++++++++++++++++++++++++++++++++++++++++++- 7 files changed, 64 insertions(+), 22 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 33d5edf..967683e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -28,7 +28,6 @@ Encoding: UTF-8 VignetteBuilder: knitr Depends: R (>= 4.1.0) Imports: - glue, rlang, utils, stats @@ -36,6 +35,7 @@ Suggests: ggplot2, covr, dplyr, + glue, gt, knitr, r2rtf, diff --git a/LICENSES_THIRD_PARTY b/LICENSES_THIRD_PARTY index f9ffa15..efbc615 100644 --- a/LICENSES_THIRD_PARTY +++ b/LICENSES_THIRD_PARTY @@ -10,7 +10,7 @@ source code license, in order to use this software. Third party R packages listed by License type [Format: Name - URL] -------------------------------------------------- - + MIT / X11 License (or adaptations) (https://www.opensource.org/licenses/MIT) * rlang - https://github.com/r-lib/rlang -* glue - https://github.com/tidyverse/glue \ No newline at end of file +* gluestick - https://github.com/coolbutuseless/gluestick diff --git a/R/adam_mapping.R b/R/adam_mapping.R index adf4352..044f524 100644 --- a/R/adam_mapping.R +++ b/R/adam_mapping.R @@ -121,11 +121,11 @@ validate_adam_mapping <- function(x) { lapply(char, function(term) { if (!is.null(x[[term]])) { if (!rlang::is_character(x[[term]])) { - rlang::abort(glue::glue("variable '{term}' must be a character value")) + rlang::abort(gluestick("variable '{term}' must be a character value")) } if (term %in% char_length_1 & length(x[[term]]) > 1L) { - rlang::abort(glue::glue("variable '{term}' must be length 1")) + rlang::abort(gluestick("variable '{term}' must be length 1")) } } }) @@ -133,7 +133,7 @@ validate_adam_mapping <- function(x) { # Check expression variable lapply(expr, function(term) { if (!(rlang::is_expression(x[[term]]) | rlang::is_null(x[[term]]))) { - rlang::abort(glue::glue("variable '{term}' must be an expression")) + rlang::abort(gluestick("variable '{term}' must be an expression")) } }) diff --git a/R/collect.R b/R/collect.R index f7fad01..cabfc39 100644 --- a/R/collect.R +++ b/R/collect.R @@ -294,7 +294,7 @@ collect_title <- function(meta, function(x) { tmp <- omit_null(collect_adam_mapping(meta, x)[c("title", "label")]) if (length(tmp) > 0) { - with(collect_adam_mapping(meta, parameter), fmt_sentence(glue::glue(tmp[[1]]))) + with(collect_adam_mapping(meta, parameter), fmt_sentence(gluestick(tmp[[1]]))) } else { NULL } diff --git a/R/collect_n_subject.R b/R/collect_n_subject.R index ea53522..6e94893 100644 --- a/R/collect_n_subject.R +++ b/R/collect_n_subject.R @@ -92,7 +92,7 @@ meta_remove_blank_group <- function(meta, pop_var <- collect_adam_mapping(meta, parameter)$var if (is.null(pop[[pop_var]])) { - stop(glue::glue("meta_remove_blank_group: parameter {pop_var} is not available in meta$population")) + stop(gluestick("meta_remove_blank_group: parameter {pop_var} is not available in meta$population")) } loc <- which(table(is.na(pop[[pop_var]]), pop[[pop_grp]])["FALSE", ] == 0) @@ -152,8 +152,8 @@ collect_n_subject <- function(meta, use_na <- match.arg(use_na) title <- c( - all = glue::glue("Number of {type}"), - with_data = glue::glue("{type} with Data"), + all = gluestick("Number of {type}"), + with_data = gluestick("{type} with Data"), missing = NA ) @@ -238,7 +238,7 @@ collect_n_subject <- function(meta, max = max(x, na.rm = TRUE) ) value <- formatC(value, format = "f", digits = 1) - c(glue::glue("{value[['mean']]} ({value[['sd']]})"), glue::glue("{value[['median']]} [{value[['min']]}, {value[['max']]}]")) + c(gluestick("{value[['mean']]} ({value[['sd']]})"), gluestick("{value[['median']]} [{value[['min']]}, {value[['max']]}]")) }) pop_num <- data.frame( name = c("Mean (SD)", "Median [Min, Max]"), @@ -253,7 +253,7 @@ collect_n_subject <- function(meta, for (i in seq(names(pop_n))) { if ("integer" %in% class(pop_n[[i]])) { pct <- formatC(pop_n[[i]] / pop_all[[i]] * 100, format = "f", digits = 1, width = 5) - pop_tmp[[i]] <- glue::glue("{pop_n[[i]]} ({pct}%)") + pop_tmp[[i]] <- gluestick("{pop_n[[i]]} ({pct}%)") } } @@ -292,7 +292,7 @@ collect_n_subject <- function(meta, for (i in seq(names(pop_tmp))) { if ("integer" %in% class(pop_tmp[[i]])) { pct <- formatC(pop_tmp[[i]] / pop_all[[i]] * 100, format = "f", digits = 1, width = 5) - pop_tmp[[i]] <- glue::glue("{pop_tmp[[i]]} ({pct}%)") + pop_tmp[[i]] <- gluestick("{pop_tmp[[i]]} ({pct}%)") } } @@ -311,7 +311,7 @@ collect_n_subject <- function(meta, # Prepare subset condition subset_condition <- function(x, name) { if (is.na(x)) { - return(glue::glue("is.na({name})")) + return(gluestick("is.na({name})")) } if (x == title["all"]) { @@ -319,10 +319,10 @@ collect_n_subject <- function(meta, } if (x == title["with_data"]) { - return(glue::glue("(! is.na({name}))")) + return(gluestick("(! is.na({name}))")) } - glue::glue("{name} == '{x}'") + gluestick("{name} == '{x}'") } var_subset <- vapply(var_level, subset_condition, name = par_var, FUN.VALUE = character(1)) @@ -370,7 +370,7 @@ collect_n_subject <- function(meta, ggplot2::facet_wrap(~group) + ggplot2::xlab(label) + ggplot2::ylab(title["all"]) + - ggplot2::ggtitle(glue::glue("Histogram of {label}")) + + ggplot2::ggtitle(gluestick("Histogram of {label}")) + ggplot2::theme_bw() # Rotate x-axis direction diff --git a/R/outdata.R b/R/outdata.R index d3480f9..ef66241 100644 --- a/R/outdata.R +++ b/R/outdata.R @@ -168,11 +168,11 @@ validate_outdata <- function(x) { lapply(num, function(term) { if (!is.null(x[[term]])) { if (!rlang::is_bare_numeric(x[[term]])) { - rlang::abort(glue::glue("variable '{term}' must be a numeric value")) + rlang::abort(gluestick("variable '{term}' must be a numeric value")) } if (term %in% num_length_1 & length(x[[term]]) > 1L) { - rlang::abort(glue::glue("variable '{term}' must be length 1")) + rlang::abort(gluestick("variable '{term}' must be length 1")) } } }) @@ -181,11 +181,11 @@ validate_outdata <- function(x) { lapply(char, function(term) { if (!is.null(x[[term]])) { if (!rlang::is_character(x[[term]])) { - rlang::abort(glue::glue("variable '{term}' must be a character value")) + rlang::abort(gluestick("variable '{term}' must be a character value")) } if (term %in% char_length_1 & length(x[[term]]) > 1L) { - rlang::abort(glue::glue("variable '{term}' must be length 1")) + rlang::abort(gluestick("variable '{term}' must be length 1")) } } }) diff --git a/R/utility.R b/R/utility.R index bea2d1f..88c0d52 100644 --- a/R/utility.R +++ b/R/utility.R @@ -54,7 +54,7 @@ check_duplicate_name <- function(x) { duplicated_names <- names(x)[duplicated(names(x))] if (length(duplicated_names) > 0L) { duplicated_message <- paste0(unique(duplicated_names), collapse = ", ") - rlang::warn(glue::glue("Duplicated name: {duplicated_message}")) + rlang::warn(gluestick("Duplicated name: {duplicated_message}")) } x } @@ -88,3 +88,45 @@ reset_label <- function(data, data_label) { data } + +#' Simple, single-function string interpolation in base R +#' +#' Drop-in replacement for the glue package. +#' Taken from (licence: MIT). +#' +#' @noRd +gluestick <- function(fmt, src = parent.frame(), open = "{", close = "}", eval = TRUE) { + nchar_open <- nchar(open) + nchar_close <- nchar(close) + + stopifnot(exprs = { + is.character(fmt) + length(fmt) == 1L + is.character(open) + length(open) == 1L + nchar_open > 0L + is.character(close) + length(close) == 1 + nchar_close > 0 + }) + + open <- gsub("(.)", "\\\\\\1", open) + close <- gsub("(.)", "\\\\\\1", close) + re <- paste0(open, ".*?", close) + + matches <- gregexpr(re, fmt) + exprs <- regmatches(fmt, matches)[[1]] + + exprs <- substr(exprs, nchar_open + 1L, nchar(exprs) - nchar_close) + + fmt_sprintf <- gsub(re, "%s", fmt) + fmt_sprintf <- gsub("%(?!s)", "%%", fmt_sprintf, perl = TRUE) + + args <- if (eval) { + lapply(exprs, function(expr) eval(parse(text = expr), envir = src)) + } else { + unname(mget(exprs, envir = as.environment(src))) + } + + do.call(sprintf, c(list(fmt_sprintf), args)) +}