1#' Format and interpolate a string 2#' 3#' Expressions enclosed by braces will be evaluated as R code. Long strings are 4#' broken by line and concatenated together. Leading whitespace and blank lines 5#' from the first and last lines are automatically trimmed. 6#' 7#' @param .x \[`listish`]\cr An environment, list, or data frame used to lookup values. 8#' @param ... \[`expressions`]\cr Unnamed arguments are taken to be expression 9#' string(s) to format. Multiple inputs are concatenated together before formatting. 10#' Named arguments are taken to be temporary variables available for substitution. 11#' @param .sep \[`character(1)`: \sQuote{""}]\cr Separator used to separate elements. 12#' @param .envir \[`environment`: `parent.frame()`]\cr Environment to evaluate each expression in. Expressions are 13#' evaluated from left to right. If `.x` is an environment, the expressions are 14#' evaluated in that environment and `.envir` is ignored. If `NULL` is passed, it is equivalent to [emptyenv()]. 15#' @param .open \[`character(1)`: \sQuote{\\\{}]\cr The opening delimiter. Doubling the 16#' full delimiter escapes it. 17#' @param .close \[`character(1)`: \sQuote{\\\}}]\cr The closing delimiter. Doubling the 18#' full delimiter escapes it. 19#' @param .transformer \[`function]`\cr A function taking three parameters `code`, `envir` and 20#' `data` used to transform the output of each block before, during, or after 21#' evaluation. For example transformers see `vignette("transformers")`. 22#' @param .na \[`character(1)`: \sQuote{NA}]\cr Value to replace `NA` values 23#' with. If `NULL` missing values are propagated, that is an `NA` result will 24#' cause `NA` output. Otherwise the value is replaced by the value of `.na`. 25#' @param .null \[`character(1)`: \sQuote{character()}]\cr Value to replace 26#' NULL values with. If `character()` whole output is `character()`. If 27#' `NULL` all NULL values are dropped (as in `paste0()`). Otherwise the 28#' value is replaced by the value of `.null`. 29#' @param .comment \[`character(1)`: \sQuote{#}]\cr Value to use as the comment 30#' character. 31#' @param .literal \[`boolean(1)`: \sQuote{FALSE}]\cr Whether to treat single or 32#' double quotes, backticks, and comments as regular characters (vs. as 33#' syntactic elements), when parsing the expression string. Setting `.literal 34#' = TRUE` probably only makes sense in combination with a custom 35#' `.transformer`, as is the case with `glue_col()`. Regard this argument 36#' (especially, its name) as experimental. 37#' @param .trim \[`logical(1)`: \sQuote{TRUE}]\cr Whether to trim the input 38#' template with [trim()] or not. 39#' @seealso <https://www.python.org/dev/peps/pep-0498/> and 40#' <https://www.python.org/dev/peps/pep-0257/> upon which this is based. 41#' @examples 42#' name <- "Fred" 43#' age <- 50 44#' anniversary <- as.Date("1991-10-12") 45#' glue('My name is {name},', 46#' 'my age next year is {age + 1},', 47#' 'my anniversary is {format(anniversary, "%A, %B %d, %Y")}.') 48#' 49#' # single braces can be inserted by doubling them 50#' glue("My name is {name}, not {{name}}.") 51#' 52#' # Named arguments can be used to assign temporary variables. 53#' glue('My name is {name},', 54#' ' my age next year is {age + 1},', 55#' ' my anniversary is {format(anniversary, "%A, %B %d, %Y")}.', 56#' name = "Joe", 57#' age = 40, 58#' anniversary = as.Date("2001-10-12")) 59#' 60#' # `glue()` can also be used in user defined functions 61#' intro <- function(name, profession, country){ 62#' glue("My name is {name}, a {profession}, from {country}") 63#' } 64#' intro("Shelmith", "Senior Data Analyst", "Kenya") 65#' intro("Cate", "Data Scientist", "Kenya") 66#' 67#' # `glue_data()` is useful in magrittr pipes 68#' if (require(magrittr)) { 69#' 70#' mtcars %>% glue_data("{rownames(.)} has {hp} hp") 71#' 72#' # Or within dplyr pipelines 73#' if (require(dplyr)) { 74#' 75#' head(iris) %>% 76#' mutate(description = glue("This {Species} has a petal length of {Petal.Length}")) 77#' 78#' }} 79#' 80#' # Alternative delimiters can also be used if needed 81#' one <- "1" 82#' glue("The value of $e^{2\\pi i}$ is $<<one>>$.", .open = "<<", .close = ">>") 83#' @useDynLib glue glue_ 84#' @name glue 85#' @export 86glue_data <- function(.x, ..., .sep = "", .envir = parent.frame(), 87 .open = "{", .close = "}", .na = "NA", .null = character(), 88 .comment = "#", .literal = FALSE, .transformer = identity_transformer, .trim = TRUE) { 89 90 if (is.null(.envir)) { 91 .envir <- emptyenv() 92 } 93 94 # Perform all evaluations in a temporary environment 95 if (is.null(.x)) { 96 parent_env <- .envir 97 } else if (is.environment(.x)) { 98 parent_env <- .x 99 } else { 100 parent_env <- list2env(as.list(.x), parent = .envir) 101 } 102 103 # Capture unevaluated arguments 104 dots <- eval(substitute(alist(...))) 105 named <- has_names(dots) 106 107 # Evaluate named arguments, add results to environment 108 env <- bind_args(dots[named], parent_env) 109 110 # Concatenate unnamed arguments together 111 unnamed_args <- lapply( 112 which(!named), 113 function(x) { 114 # Any evaluation to `NULL` is replaced with `.null`: 115 # - If `.null == character()` then if any output's length is 0 the 116 # whole output should be forced to be `character(0)`. 117 # - If `.null == NULL` then it is allowed and any such argument will be 118 # silently dropped. 119 # - In other cases output is treated as it was evaluated to `.null`. 120 eval(call("force", as.symbol(paste0("..", x)))) %||% .null 121 } 122 ) 123 unnamed_args <- drop_null(unnamed_args) 124 125 if (length(unnamed_args) == 0) { 126 # This is equivalent to `paste0(NULL)` 127 return(as_glue(character(0))) 128 } 129 130 lengths <- lengths(unnamed_args) 131 if (any(lengths == 0)) { 132 return(as_glue(character(0))) 133 } 134 if (any(lengths != 1)) { 135 stop("All unnamed arguments must be length 1", call. = FALSE) 136 } 137 if (any(is.na(unnamed_args))) { 138 if (is.null(.na)) { 139 return(as_glue(NA_character_)) 140 } else { 141 unnamed_args[is.na(unnamed_args)] <- .na 142 } 143 } 144 145 unnamed_args <- paste0(unnamed_args, collapse = .sep) 146 if (isTRUE(.trim)) { 147 unnamed_args <- trim(unnamed_args) 148 } 149 150 f <- function(expr){ 151 eval_func <- .transformer(expr, env) %||% .null 152 153 # crayon functions *can* be used, so we use tryCatch() 154 # to give as.character() a chance to work 155 tryCatch( 156 # Output can be `NULL` only if `.null` is `NULL`. Then it should be 157 # returned as is, because `as.character(NULL)` is `character()`. 158 if (is.null(eval_func)) NULL else as.character(eval_func), 159 error = function(e) { 160 # if eval_func is a function, provide informative error-message 161 if (is.function(eval_func)) { 162 message <- paste0( 163 "glue cannot interpolate functions into strings.\n", 164 "* object '", 165 expr, 166 "' is a function." 167 ) 168 169 stop(message, call. = FALSE) 170 } 171 172 # default stop 173 stop(e) 174 } 175 ) 176 } 177 178 # Parse any glue strings 179 res <- .Call(glue_, unnamed_args, f, .open, .close, .comment, .literal) 180 181 res <- drop_null(res) 182 183 if (any(lengths(res) == 0)) { 184 return(as_glue(character(0))) 185 } 186 187 if (!is.null(.na)) { 188 res[] <- lapply(res, function(x) replace(x, is.na(x), .na)) 189 } else { 190 na_rows <- na_rows(res) 191 } 192 193 res <- do.call(paste0, recycle_columns(res)) 194 195 if (is.null(.na)) { 196 res <- replace(res, na_rows, NA) 197 } 198 199 as_glue(res) 200} 201 202#' @export 203#' @rdname glue 204glue <- function(..., .sep = "", .envir = parent.frame(), .open = "{", .close = "}", .na = "NA", .null = character(), .comment = "#", .literal = FALSE, .transformer = identity_transformer, .trim = TRUE) { 205 glue_data(.x = NULL, ..., .sep = .sep, .envir = .envir, .open = .open, .close = .close, .na = .na, .null = .null, .comment = .comment, .literal = .literal, .transformer = .transformer, .trim = .trim) 206} 207 208#' Collapse a character vector 209#' 210#' `glue_collapse()` collapses a character vector of any length into a length 1 vector. 211#' `glue_sql_collapse()` does the same but returns a `[DBI::SQL()]` 212#' object rather than a glue object. 213#' 214#' @param x The character vector to collapse. 215#' @param width The maximum string width before truncating with `...`. 216#' @param last String used to separate the last two items if `x` has at least 217#' 2 items. 218#' @inheritParams base::paste 219#' @examples 220#' glue_collapse(glue("{1:10}")) 221#' 222#' # Wide values can be truncated 223#' glue_collapse(glue("{1:10}"), width = 5) 224#' 225#' glue_collapse(1:4, ", ", last = " and ") 226#' #> 1, 2, 3 and 4 227#' @export 228glue_collapse <- function(x, sep = "", width = Inf, last = "") { 229 if (length(x) == 0) { 230 return(as_glue(character())) 231 } 232 if (any(is.na(x))) { 233 return(as_glue(NA_character_)) 234 } 235 236 if (nzchar(last) && length(x) > 1) { 237 res <- glue_collapse(x[seq(1, length(x) - 1)], sep = sep, width = Inf) 238 return(glue_collapse(paste0(res, last, x[length(x)]), width = width)) 239 } 240 x <- paste0(x, collapse = sep) 241 if (width < Inf) { 242 x_width <- nchar(x, "width") 243 too_wide <- x_width > width 244 if (too_wide) { 245 x <- paste0(substr(x, 1, width - 3), "...") 246 } 247 } 248 as_glue(x) 249} 250 251#' Trim a character vector 252#' 253#' This trims a character vector according to the trimming rules used by glue. 254#' These follow similar rules to [Python Docstrings](https://www.python.org/dev/peps/pep-0257/), 255#' with the following features. 256#' - Leading and trailing whitespace from the first and last lines is removed. 257#' - A uniform amount of indentation is stripped from the second line on, equal 258#' to the minimum indentation of all non-blank lines after the first. 259#' - Lines can be continued across newlines by using `\\`. 260#' @param x A character vector to trim. 261#' @export 262#' @examples 263#' glue(" 264#' A formatted string 265#' Can have multiple lines 266#' with additional indention preserved 267#' ") 268#' 269#' glue(" 270#' \ntrailing or leading newlines can be added explicitly\n 271#' ") 272#' 273#' glue(" 274#' A formatted string \\ 275#' can also be on a \\ 276#' single line 277#' ") 278 279#' @useDynLib glue trim_ 280trim <- function(x) { 281 has_newline <- function(x) any(grepl("\\n", x)) 282 if (length(x) == 0 || !has_newline(x)) { 283 return(x) 284 } 285 .Call(trim_, x) 286} 287 288#' @export 289print.glue <- function(x, ..., sep = "\n") { 290 x[is.na(x)] <- style_na(x[is.na(x)]) 291 292 if (length(x) > 0) { 293 cat(x, ..., sep = sep) 294 } 295 296 invisible(x) 297} 298 299#' Coerce object to glue 300#' @param x object to be coerced. 301#' @param ... further arguments passed to methods. 302#' @export 303as_glue <- function(x, ...) { 304 UseMethod("as_glue") 305} 306 307#' @export 308as_glue.default <- function(x, ...) { 309 as_glue(as.character(x)) 310} 311 312#' @export 313as_glue.glue <- function(x, ...) { 314 x 315} 316 317#' @export 318as_glue.character <- function(x, ...) { 319 class(x) <- c("glue", "character") 320 enc2utf8(x) 321} 322 323#' @export 324as.character.glue <- function(x, ...) { 325 unclass(x) 326} 327 328#' @export 329`[.glue` <- function(x, i, ...) { 330 as_glue(NextMethod()) 331} 332 333#' @export 334`[[.glue` <- function(x, i, ...) { 335 as_glue(NextMethod()) 336} 337 338#' @export 339`+.glue` <- function(e1, e2) { 340 glue(e1, e2, .envir = parent.frame()) 341} 342 343#' @importFrom methods setOldClass 344setOldClass(c("glue", "character")) 345 346 347#' Deprecated Functions 348#' 349#' These functions are Deprecated in this release of glue, they will be removed 350#' in a future version. 351#' @name glue-deprecated 352#' @keywords internal 353NULL 354