R/glue.R

In marquee: Markdown Parser and Renderer for R Graphics

#' Marquee-aware string interpolation
#'
#' If you want to create your markdown programmatically you'd probably want to
#' use some sort of string interpolation such as `glue()`. However, the custom
#' span syntax of marquee interferes with the standard interpolation syntax of
#' glue. This function let's you use both together.
#'
#' @inheritParams glue::glue_data
#'
#' @return A character vector
#'
#' @details
#' If you choose a different set of delimiters than `"{"` and `"}"` for the
#' interpolation the functions will call the equivalent glue functions directly.
#' However, if you keep the defaults, the functions will use a custom
#' transformer that will make sure to keep the marquee custom span notation. You
#' can both interpolate the content of the span, as well as the span class (see
#' examples)
#'
#' @export
#'
#' @examples
#' # standard use
#' red_text <- "this text will be red"
#' marquee_glue("This will be black and {.red {red_text}}!")
#'
#' # if the span is not valid it will be treated as standard glue interpolation
#' try(
#'   marquee_glue("This will be black and {.red}!")
#' )
#'
#' # You can interpolate the tag name as well
#' col <- "green"
#' marquee_glue("This will be black and {.{col} this text will be {col}}!")
#'
#' # Tag name interpolation must follow a `.` or a `#` as these identify the
#' # bracket pair as a custom span class
#' col <- ".yellow"
#' # This is not what you want probably
#' marquee_glue("This will be black and {{col} this text will be {col}}!")
#'
#' # Tag interpolation should also interpolate the full tag and be followed by
#' # a space in order to be valid
#' part <- "l"
#' marquee_glue("This will be black and {.ye{part}low this text will be {col}}!")
#' try(
#'   marquee_glue("This will be black and {.{part}avender this text will be {col}}!")
#' )
#'
marquee_glue <- function(
  ...,
  .sep = "",
  .envir = parent.frame(),
  .open = "{",
  .close = "}",
  .na = "NA",
  .null = character(),
  .comment = character(),
  .literal = FALSE,
  .transformer = NULL,
  .trim = TRUE
) {
  if (.open != "{" && .close != "}") {
    .transformer <- .transformer %||% glue::identity_transformer
  } else {
    if (!is.null(.transformer)) {
      cli::cli_warn(
        "Ignoring supplied {.arg .transformer} when using {.val {'{'}} and  {.val {'}'}} as delimiters"
      )
    }
    .transformer <- marquee_transformer(.na, .null, .comment, .literal)
  }

  glue::glue(
    ...,
    .sep = .sep,
    .envir = .envir,
    .open = .open,
    .close = .close,
    .na = .na,
    .null = .null,
    .comment = .comment,
    .literal = .literal,
    .transformer = .transformer,
    .trim = .trim
  )
}
#' @rdname marquee_glue
#' @export
marquee_glue_data <- function(
  .x,
  ...,
  .sep = "",
  .envir = parent.frame(),
  .open = "{",
  .close = "}",
  .na = "NA",
  .null = character(),
  .comment = character(),
  .literal = FALSE,
  .transformer = NULL,
  .trim = TRUE
) {
  if (.open != "{" && .close != "}") {
    .transformer <- .transformer %||% glue::identity_transformer
  } else {
    if (!is.null(.transformer)) {
      cli::cli_warn(
        "Ignoring supplied {.arg .transformer} when using {.val {'{'}} and  {.val {'}'}} as delimiters"
      )
    }
    .transformer <- marquee_transformer(.na, .null, .comment, .literal)
  }

  glue::glue_data(
    .x,
    ...,
    .sep = .sep,
    .envir = .envir,
    .open = .open,
    .close = .close,
    .na = .na,
    .null = .null,
    .comment = .comment,
    .literal = .literal,
    .transformer = .transformer,
    .trim = .trim
  )
}

marquee_transformer <- function(
  .na = "NA",
  .null = character(),
  .comment = character(),
  .literal = FALSE
) {
  function(text, envir) {
    first <- substr(text, 1, 1)
    if (first %in% c(".", "#")) {
      if (substr(text, 2, 2) == "{") {
        tag_ends <- regexec("}", text, fixed = TRUE)[[1]]
        if (substr(text, tag_ends + 1L, tag_ends + 1L) != " ") {
          cli::cli_abort(
            "Malformed marquee interpolation block. When interpolating a tag name it must be followed by a space"
          )
        }
        tag <- glue::identity_transformer(substr(text, 2, tag_ends), envir)
        if (grepl("\\s", tag)) {
          cli::cli_abort("evaluated tag ({.val {tag}}) is not a valid tag name")
        }
      } else {
        tag_ends <- regexec("\\s", text)[[1]]
        if (tag_ends == -1) return(glue::identity_transformer(text, envir))
        tag_ends <- tag_ends - 1L
        tag <- substr(text, 2, tag_ends)
      }
      body <- glue::glue(
        substr(text, tag_ends + 2L, nchar(text)),
        .envir = envir,
        .na = .na,
        .null = .null,
        .comment = .comment,
        .literal = .literal,
        .transformer = caller_fn(n = 0)
      )
      paste0("{", first, tag, " ", body, "}")
    } else {
      glue::identity_transformer(text, envir)
    }
  }
}