Replace glue with gluestick

DESCRIPTION

@@ -28,14 +28,14 @@ Encoding: UTF-8
 VignetteBuilder: knitr
 Depends: R (>= 4.1.0)
 Imports:
-    glue,
     rlang,
     utils,
     stats
 Suggests:
     ggplot2,
     covr,
     dplyr,
+    glue,
     gt,
     knitr,
     r2rtf,

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
+* gluestick - https://github.com/coolbutuseless/gluestick

R/adam_mapping.R

@@ -121,19 +121,19 @@ 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"))
       }
     }
   })
 
   # 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"))
     }
   })
 

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
       }

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,18 +311,18 @@ 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"]) {
       return("TRUE")
     }
 
     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

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

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 <https://github.com/coolbutuseless/gluestick> (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))
+}