Proof of concept for a guide based on {marquee}. It can interpolate text with symbols created as a legend and recolour parts of text to match a scale's colour.

guide_marquee.R

library(ggplot2)
library(marquee)
library(rlang)
library(grid)
library(gtable)

# Constructor -------------------------------------------------------------

#' Text guide
#'
#' Can display keys interpolated with text and re-colour text according to
#' colour or fill scale.
#'
#' @inheritParams guide_legend
#' @param label_style A `<marquee_style>` object created by `marquee::style()`.
#'   The `color`, `border` and `background` parameters can take one of the
#'   keywords `"recolour"` or `"contrast"` to fill in the colour from the scale
#'   (`"recolour"`) or be black and white to enhance contrast with the scale's
#'   colours (`"contrast"`). These keywords only matter when the scale represent
#'   the `colour` or `fill` aesthetic. The helper functions `style_recolour()`,
#'   `style_border()` and `style_background()` are available to conveniently
#'   set a style.
#' @param detect A boolean. If `TRUE`, the text is scanned for the presence of
#'   labels and is assigned the `label_style` automatically. If `FALSE`
#'   (default), pieces of text representing labels should be indicated with
#'   marquee syntax, see details below.
#'
#' @return A <Guide> object that can be provided to a scale or the `guides()`
#'   function.
#' @export
#'
#' ## Text formatting
#'
#' This guide uses {marquee}'s syntax to format text. There is also additional
#' syntax available to make building a guide easier. In the text below, `n`
#' represents the `n`-th break in the scale, `label` represents any of
#' the scale's labels and `foo` represents arbitrary text.
#'
#' * `<<n>>` or `<<label>>` can be used to insert key glyphs into text.
#' * `![](n)` or `![](label)` can also be used to insert key glyphs into text.
#' * `{.n foo}` or `{.label foo}` applies the `label_style` to `foo`, including
#'   recolouring or contrasting when the guide represents a colour or fill scale.
#' * `!!n` translates to `{.label label}` to insert a formatted label based on
#'   their order.
#'
#' @examples
#' # A standard plot
#' base <- ggplot(mpg, aes(displ, hwy)) +
#'   geom_point()
#'
#' # Inserting glyphs
#' base + aes(shape = drv) +
#'   scale_shape_discrete(
#'     # Same as using <<1>>, <<2>> and <<3>>,
#'     # or ![](1), ![](2) and ![](3)
#'     # or ![](4), ![](f) and ![](r)
#'     "Cars with four wheel <<4>>, forward <<f>> or reverse <<r>> drive.",
#'     guide = "marquee"
#'   )
#'
#' # Recolouring text
#' base + aes(colour = drv) +
#'   scale_colour_discrete(
#'     # Same as using {.1 four wheel}, {.2 forward} and {.3 reverse}
#'     "Cars with {.4 four wheel}, {.f forward} or {.r reverse} drive.",
#'     guide = "marquee"
#'   )
#'
#' # Inserting labels
#' base + aes(colour = class) +
#'   scale_colour_discrete(
#'     "Cars including !!2 and !!6 vehicles",
#'     guide = "marquee"
#'   )
#'
#' # Automatic label detection
#' base + aes(colour = class) +
#'   scale_colour_discrete(
#'     "Cars including suv and minivan vehicles",
#'     guide = guide_marquee(detect = TRUE)
#'   )
#'
#' # With automatic detection every occurrance counts, which is not always good
#' base + aes(colour = drv) +
#'   scale_colour_discrete(
#'     "The riffraff eats frankfurthers 4 ever",
#'     guide = guide_marquee(detect = TRUE)
#'   )
#'
#' # Adjust the label style to emphasise what parts are labels
#' base + aes(shape = drv) +
#'   scale_shape_discrete(
#'     "Cars with {.4 four wheel} <<4>>, {.f forward} <<f>> or {.r reverse} <<r>> drive.",
#'     guide = guide_marquee(label_style = style(italic = TRUE))
#'   )
#'
#' # Using the background style makes labels white on dark backgrounds and black
#' # on light backgrounds.
#' base + aes(colour = drv) +
#'   scale_colour_manual(
#'     "Cars with {.4 four wheel}, {.f forward} or {.r reverse} drive.",
#'     values = c("grey90", "grey10", "red"),
#'     guide = guide_marquee(label_style = style_background())
#'   ) +
#'   theme(plot.subtitle = element_text(colour = "grey50"))
guide_marquee <- function(
  title = waiver(),
  label_style = style_recolour(),
  detect = FALSE,
  theme = NULL,
  position = "top",
  override.aes = list(),
  order = 1,
  ...
) {
  new_guide(
    title = title,
    available_aes = "any",
    order = order,
    detect = detect,
    position = position,
    label_style = label_style,
    theme = theme,
    super = GuideMarquee
  )
}

# Class -------------------------------------------------------------------

GuideMarquee <- ggproto(
  "GuideMarquee", GuideLegend,

  params = list2(
    !!!Guide$params, override.aes = list(),
    label_style = style(), detect = FALSE
  ),

  elements = list(title = "plot.subtitle", spacing = "legend.box.spacing",
                  key = "legend.key"),

  setup_elements = function(params, elements, theme) {
    elements <- Guide$setup_elements(params, elements, theme)
    if (!inherits(elements$title, "element_marquee")) {
      elements$title <- merge_element(element_marquee(), elements$title)
    }
    i <- match(params$position, c("bottom", "left", "top", "right"))
    # Offset for legend.box.spacing so that it is spaced like a normal subtitle
    elements$title$margin[i] <- elements$title$margin[i] - elements$spacing
    elements$key <- element_grob(elements$key)
    elements
  },

  draw = function(
    self, theme, position = NULL, direction = NULL, params = self$params
  ) {
    params$position  <- params$position  %||% position
    params$direction <- params$direction %||% direction %||%
      switch(params$position, top = , bottom = "horizontal", "vertical")

    elems <- self$setup_elements(params, self$elements, theme)

    text <- params$title
    labs <- params$key$.label

    glyphs <- group_glyphs(params, elems, elems$title$size)
    text   <- insert_glyphs(text, glyphs, labs)
    text   <- replace_tags(text, labs, params)

    # By default, turn off the bottom margin of the style
    style <- elems$title$style %||% classic_style(margin = trbl(0, 0))
    style <- recolour_style(style, text, params)

    if (params$position %in% c("top", "bottom")) {
      width <- unit(1, "npc")
    } else {
      width <- calc_element("legend.key.width", theme) * 5
    }

    grob <- withr::with_environment(
      list2env(glyphs),
      element_grob(
        elems$title, label = text, width = width,
        margin_x = FALSE, margin_y = TRUE, style = style
      )
    )

    gtable(widths = width, heights = grobHeight(grob)) |>
      gtable_add_grob(grob, t = 1, l = 1, clip = "off", name = "guide")
  }
)

# Style helpers -----------------------------------------------------------

#' Wrappers for `style()`
#'
#' These functions are wrappers for `marquee::style()` that can be given as
#' the `label_style` argument in `guide_marquee()`. They may set some colours
#' to keywords, which will not make sense outside `guide_marquee()`.
#'
#' @inheritParams marquee::style
#' @inheritDotParams marquee::style
#'
#' @return A `<marquee_style>` object.
#' @name style_guide_marquee
NULL

#' @export
#' @rdname style_guide_marquee
style_recolour <- function(color = "recolour", ...) {

  style(color = color, ...)

}

#' @export
#' @rdname style_guide_marquee
style_border <- function(border = "recolour", padding = trbl(em(0.1), 0),
                         background = NA, border_size = trbl(1),
                         border_radius = rem(0.2), ...) {

  style(
    border = border, padding = padding,
    background = background, border_size = border_size,
    border_radius = border_radius, ...
  )

}

#' @export
#' @rdname style_guide_marquee
style_background <- function(color = "contrast", padding = trbl(em(0.1), 0),
                             background = "recolour", border = NA,
                             border_radius = rem(0.2), ...) {

  style(
    color = color, padding = padding, background = background,
    border = border, border_radius = border_radius,
    ...
  )

}

# Internal helpers --------------------------------------------------------

insert_glyphs <- function(text, glyphs, labels) {

  img <- paste0("![](", names(glyphs), ")")
  n <- rev(seq_along(glyphs))

  # Replace `"![](1)"` and `"![](label)"` with glyph images
  if (grepl(x = text, "![](", fixed = TRUE)) {
    num <- paste0("![](", seq_along(glyphs), ')')
    lab <- paste0("![](", labels, ")")
    for (i in n) {
      text <- gsub(x = text, num[i], img[i], fixed = TRUE)
      text <- gsub(x = text, lab[i], img[i], fixed = TRUE)
    }
  }

  # Replace `"<<1>>"` and `"<<label>>"` with glyph images
  if (grepl(x = text, "<<.*>>")) {
    num <- paste0("<<", seq_along(glyphs), ">>")
    lab <- paste0("<<", labels, ">>")
    for (i in n) {
      text <- gsub(x = text, num[i], img[i], fixed = TRUE)
      text <- gsub(x = text, lab[i], img[i], fixed = TRUE)
    }
  }

  text
}

replace_tags <- function(text, labels, params) {

  n <- rev(seq_along(labels))

  # Replace `"!!1"` tokens with `"{.label label}"`
  relabel  <- paste0("{.", labels, " ", labels, "}")
  if (grepl(x = text, "\\!\\!")) {
    num <- paste0("!!", seq_along(labels))
    lab <- paste0("!!", labels)
    for (i in n) {
      text <- gsub(x = text, num[i], relabel[i])
      text <- gsub(x = text, lab[i], relabel[i])
    }
  }

  # Replace `"{.1 xxx}"` pattern with `"{.label xxx}" pattern`
  retag <- paste0("{.", labels, " ")
  for (i in rev(seq_along(retag))) {
    text <- gsub(x = text, paste0("\\{\\.", i, " "), retag[i])
  }

  if (isTRUE(params$detect)) {
    # TODO: this is really naive and will also match glyphs and tags
    for (i in n) {
      text <- gsub(x = text, labels[i], relabel[i], fixed = TRUE)
    }
  }

  text
}

recolour_style = function(style, text, params) {
  key <- params$key
  keywords <- c("recolour", "contrast")
  label <- params$label_style %||% style()

  # Turn off recolouring if this is not a colour/fill guide
  is_colour_scale <- any(c("colour", "fill") %in% names(key))
  if (!is_colour_scale) {
    fields <- c("color", "border", "background")
    for (field in fields) {
      if (isTRUE(label[[field]] %in% keywords)) {
        label[field] <- list(NULL)
      }
    }
  }

  # Initialise label styles
  style <- modify_style(style, "label", label)
  for (i in key$.label) {
    style <- modify_style(style, i, label)
  }

  # Find out if label style allows for recolouring, early exit if it doesn't
  if (!is_colour_scale ||
      !isTRUE(label$color      %in% keywords) &&
      !isTRUE(label$border     %in% keywords) &&
      !isTRUE(label$background %in% keywords)) {
    return(style)
  }

  # Find out which keys are represented in text
  idx <- which(vapply(
    paste0("\\{\\.", key$.label),
    grepl, x = text[1],
    FUN.VALUE = logical(1)
  ))

  # Early exit if no keys are represented in text
  if (length(idx) == 0) {
    return(style)
  }

  # Populate re-coloured parameters
  key_colour <- key$colour %||% key$fill
  contrast   <- auto_contrast(key_colour)
  n <- nrow(key)

  colour <- switch(
    label$color %||% "null",
    recolour = key_colour,
    contrast = contrast,
    rep(label$color, n)
  )

  border <- switch(
    label$border %||% "null",
    recolour = key_colour,
    contrast = contrast,
    rep(label$border, n)
  )

  background <- switch(
    label$background %||% "null",
    recolour = key_colour,
    contrast = contrast,
    rep(label$background, n)
  )

  # Set relevant tags in style
  for (i in idx) {
    style <- modify_style(
      style, tag = key$.label[i],
      color      = colour[i],
      border     = border[i],
      background = background[i]
    )
  }
  style
}

group_glyphs <- function(params, elems, size) {
  n_layers <- length(params$decor) + 1
  n_breaks <- params$n_breaks <- nrow(params$key)
  size <- convertUnit(unit(size, "pt"), "cm", valueOnly = TRUE)

  glyphs <- GuideLegend$build_decor(params$decor, list(), elems, params)
  glyphs <- split(glyphs, rep(seq_len(n_breaks), each = n_layers))
  glyphs <- lapply(glyphs, function(key) {

    width <- lapply(key, attr, which = "width")
    width[lengths(width) != 1] <- 0
    width <- max(unlist(width))

    height <- lapply(key, attr, which = "height")
    height[lengths(height) != 1] <- 0
    height <- max(unlist(height))

    vp <- NULL
    if (width != 0 || height != 0) {
      vp <- viewport(
        width  = unit(max(width, size),  "cm"),
        height = unit(max(height, size), "cm")
      )
    }
    inject(grobTree(!!!key, vp = vp))
  })
  names(glyphs) <- paste0("GLYPH_", params$key$.label)
  glyphs
}

auto_contrast <- function(colour) {
  out <- rep("black", length(colour))
  light <- farver::get_channel(colour, "l", space = "hcl")
  out[light < 50] <- "white"
  out
}