1#' Construct strings with color
2#'
3#' @description
4#' The [crayon][crayon::crayon] package defines a number of functions used to
5#' color terminal output. `glue_col()` and `glue_data_col()` functions provide
6#' additional syntax to make using these functions in glue strings easier.
7#'
8#' Using the following syntax will apply the function [crayon::blue()] to the text 'foo bar'.
9#'
10#' ```
11#' {blue foo bar}
12#' ```
13#'
14#' If you want an expression to be evaluated, simply place that in a normal brace
15#' expression (these can be nested).
16#'
17#' ```
18#' {blue 1 + 1 = {1 + 1}}
19#' ```
20#'
21#' If the text you want to color contains, e.g., an unpaired quote or a comment
22#' character, specify `.literal = TRUE`.
23#'
24#' @inheritParams glue
25#' @export
26#' @examplesIf require(crayon)
27#' library(crayon)
28#'
29#' glue_col("{blue foo bar}")
30#'
31#' glue_col("{blue 1 + 1 = {1 + 1}}")
32#'
33#' glue_col("{blue 2 + 2 = {green {2 + 2}}}")
34#'
35#' white_on_black <- bgBlack $ white
36#' glue_col("{white_on_black
37#'   Roses are {red {colors()[[552]]}},
38#'   Violets are {blue {colors()[[26]]}},
39#'   `glue_col()` can show \\
40#'   {red c}{yellow o}{green l}{cyan o}{blue r}{magenta s}
41#'   and {bold bold} and {underline underline} too!
42#' }")
43#'
44#' # this would error due to an unterminated quote, if we did not specify
45#' # `.literal = TRUE`
46#' glue_col("{yellow It's} happening!", .literal = TRUE)
47#'
48#' # `.literal = TRUE` also prevents an error here due to the `#` comment
49#' glue_col(
50#'   "A URL: {magenta https://github.com/tidyverse/glue#readme}",
51#'   .literal = TRUE
52#' )
53#'
54#' # `.literal = TRUE` does NOT prevent evaluation
55#' x <- "world"
56#' y <- "day"
57#' glue_col("hello {x}! {green it's a new {y}!}", .literal = TRUE)
58glue_col <- function(..., .envir = parent.frame(), .na = "NA", .literal = FALSE) {
59  glue(..., .envir = .envir, .na = .na, .literal = .literal, .transformer = color_transformer)
60}
61
62#' @rdname glue_col
63#' @export
64glue_data_col <- function(.x, ..., .envir = parent.frame(), .na = "NA", .literal = FALSE) {
65  glue_data(.x, ..., .envir = .envir, .na = .na, .literal = .literal, .transformer = color_transformer)
66}
67
68color_transformer <- function(code, envir) {
69  res <- tryCatch(parse(text = code, keep.source = FALSE), error = function(e) e)
70  if (!inherits(res, "error")) {
71    return(eval(res, envir = envir))
72  }
73
74  code <- glue_collapse(code, "\n")
75  m <- regexpr("(?s)^([[:alnum:]_]+)[[:space:]]+(.+)", code, perl = TRUE)
76  has_match <- m != -1
77  if (!has_match) {
78    stop(res)
79  }
80  starts <- attr(m, "capture.start")
81  ends <- starts + attr(m, "capture.length") - 1L
82  captures <- substring(code, starts, ends)
83  fun <- captures[[1]]
84  text <- captures[[2]]
85  out <- glue(text, .envir = envir, .transformer = color_transformer)
86
87  color_fun <- get0(fun, envir = envir, mode = "function")
88  if (is.null(color_fun) && requireNamespace("crayon", quietly = TRUE)) {
89    color_fun <- get0(fun, envir = asNamespace("crayon"), mode = "function")
90  }
91
92  if (is.null(color_fun)) {
93    # let nature take its course, i.e. throw the usual error
94    get(fun, envir = envir, mode = "function")
95  } else {
96    color_fun(out)
97  }
98}
99