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