From cea3e3d69cd0a677de13727a6d6e96c499d766e0 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Jun 2024 11:47:38 +0200 Subject: [PATCH 1/9] add {gtable} to suggests --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 3dcdb96..33fb674 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -30,6 +30,7 @@ Imports: Suggests: ggplot2, gt, + gtable, knitr, patchwork, ragg, From 99862d13bc17120e620101bd8b62cbcf01102911 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Jun 2024 11:49:08 +0200 Subject: [PATCH 2/9] add `guide_marquee()` --- NAMESPACE | 1 + R/guide_marquee.R | 275 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 276 insertions(+) create mode 100644 R/guide_marquee.R diff --git a/NAMESPACE b/NAMESPACE index cf92480..a57100d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -34,6 +34,7 @@ export(classic_style) export(element_marquee) export(em) export(geom_marquee) +export(guide_marquee) export(marquee_bullets) export(marquee_glue) export(marquee_glue_data) diff --git a/R/guide_marquee.R b/R/guide_marquee.R new file mode 100644 index 0000000..ae662ba --- /dev/null +++ b/R/guide_marquee.R @@ -0,0 +1,275 @@ +guide_marquee <- function(title = ggplot2::waiver(), + # Note: prefixing namespace prevents recursive default argument + style = marquee::style(background = NA), + detect = FALSE, theme = NULL, position = "top", + override.aes = list(), order = 1) { + check_installed("ggplot2", version = "3.5.0") + if (!(ggplot2::is.theme(theme) || is.null(theme))) { + stop_input_type(theme, "a ") + } + if (!is.null(position)) { + arg_match0(position, c("top", "right", "bottom", "left")) + } + if (!(is_style(style) || is_style_set(style))) { + stop_input_type(style, "a or ") + } + if (!is_bare_list(override.aes)) { + stop_input_type(override.aes, "a bare ") + } + ggplot2::new_guide( + title = title, + available_aes = "any", + order = order, + detect = detect, + position = position, + style = style, + theme = theme, + override.aes = override.aes, + super = GuideMarquee + ) +} + +on_load( + makeActiveBinding("GuideMarquee", function() guide_env$guide, environment(guide_marquee)) +) + +guide_env <- new_environment(list(guide = NULL)) + +make_marquee_guide <- function() { + if ("GuideLegend" %in% getNamespaceExports("ggplot2")) { + # We don't use guide classes directly as earlier ggplot2 versions might + # be loaded where they don't exist. + parent <- utils::getFromNamespace("GuideLegend", "ggplot2") + base <- utils::getFromNamespace("Guide", "ggplot2") + } else { + return(NULL) + } + + guide_env$guide <- ggplot2::ggproto( + "GuideMarquee", parent, + + params = list( + title = ggplot2::waiver(), theme = NULL, name = "guide_marquee", + position = NULL, direction = NULL, order = 0, hash = character(), + style = style(), detect = FALSE, override.aes = list() + ), + + elements = list( + title = "plot.subtitle", + spacing = "legend.box.spacing", + key = "legend.key" + ), + + draw = function(self, theme, position = NULL, direction = NULL, + params = self$params) { + + params$position <- params$position %||% position + + elems <- base$setup_elements(params, self$elements, theme) + # Enforce the title to be a marquee element + if (!inherits(elems$title, "element_marquee")) { + elems$title <- ggplot2::merge_element(element_marquee(), elems$title) + } + # We offset the margin to counteract the legend.box.spacing so that + # it resembles a regular subtitle better + i <- match(params$position, c("bottom", "left", "top", "right")) + elems$title$margin[i] <- elems$title$margin[i] - elems$spacing + elems$key <- ggplot2::element_grob(elems$key) + + text <- params$title + labs <- params$key$.label + check_string(text, arg = "title") + check_character(labs, arg = "labels") + + # Place image and label tags + glyphs <- group_glyphs(self, params, elems) + text <- weave_glyphs(text, glyphs, labs) + text <- replace_tags(text, labs, params$detect) + + # Set style colour + style <- elems$title$style %||% classic_style() + style <- recolour_style(style, text, params) + + if (params$position %in% c("top", "bottom")) { + width <- unit(1, "npc") + } else { + width <- ggplot2::calc_element("legend.key.width", theme) * 5 + } + + # TODO: this is a hack until #24 is solved + f <- element_grob.element_marquee + fn_env(f) <- list2env(glyphs) + for (i in names(glyphs)) { + environment(f)[[i]] <- glyphs[[i]] + } + grob <- f(elems$title, label = text, width = width, margin_y = TRUE, style = style) + + gt <- gtable::gtable(widths = width, heights = grobHeight(grob)) + gtable::gtable_add_grob( + gt, grob, t = 1, l = 1, + clip = "off", name = params$name + ) + } + ) +} + +on_load(on_package_load("ggplot2", { + make_marquee_guide() +})) + +group_glyphs <- function(self, params, elems) { + + n_layers <- length(params$decor) + 1 + n_breaks <- params$n_breaks <- nrow(params$key) + size <- convertUnit(unit(elems$title$size, "pt"), "cm", valueOnly = TRUE) + + glyphs <- self$build_decor(params$decor, list(), elems, params) + glyphs <- split(glyphs, rep(seq_len(n_breaks), each = n_layers)) + + # Combine glyphs coming from multiple layers and respect their alotted size + 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 +} + +weave_glyphs <- function(text, glyphs, labels) { + + img_tag <- paste0("![](", names(glyphs), ")") + n <- rev(seq_along(glyphs)) + # TODO: figure out what to do when `any(n %in% labels)` + + # 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_tag[i], fixed = TRUE) + text <- gsub(x = text, lab[i], img_tag[i], fixed = TRUE) + } + } + + if (grepl(x = text, "<<.*>>")) { + num <- paste0("<<", seq_along(glyphs), ">>") + lab <- paste0("<<", labels, ">>") + for (i in n) { + text <- gsub(x = text, num[i], img_tag[i], fixed = TRUE) + text <- gsub(x = text, lab[i], img_tag[i], fixed = TRUE) + } + } + + text +} + +replace_tags <- function(text, labels, detect) { + + n <- rev(seq_along(labels)) + tags <- vctrs::vec_as_names(labels, repair = "universal", quiet = TRUE) + + # Replace "!!1" and "!!labels" with "{.label label} + relabel <- paste0("{.", tags, " ", labels, "}") + if (grepl(x = text, "!!", fixed = TRUE)) { + num <- paste0("!!", seq_along(labels)) + lab <- paste0("!!", labels) + for (i in n) { + text <- gsub(x = text, num[i], relabel[i], fixed = TRUE) + text <- gsub(x = text, lab[i], relabel[i], fixed = TRUE) + } + } + + # Replace `"{.1 xxx}` pattern with `"{.label xxx}"` pattern + retag <- paste0("{.", tags, " ") + num <- paste0("{.", seq_along(labels), " ") + lab <- paste0("{.", labels, " ") + for (i in n) { + text <- gsub(x = text, num[i], retag[i], fixed = TRUE) + text <- gsub(x = text, lab[i], retag[i], fixed = TRUE) + } + + if (isTRUE(detect)) { + # TODO: this is really naive and might match glyphs and tags + labels <- regescape(labels) + for (i in n) { + text <- gsub(x = text, labels[i], relabel[i]) + } + } + + text +} + +# Based on stringr::str_escape +regescape <- function(x) { + gsub(x = x, "([.^$\\\\|*+?{}\\[\\]()])", "\\\\\\1", perl = TRUE) +} + +recolour_style <- function(style, text, params) { + + key <- params$key + label <- params$style %||% style() + if (is_style_set(label)) { + style <- label + label <- style(background = NA) + } + + # Initialise label style + if (!"label" %in% names(style[[1]])) { + style <- modify_style(style, "label", label) + } else { + label <- style[[1]]$label + } + + tags <- vctrs::vec_as_names(key$.label, repair = "universal", quiet = TRUE) + for (tag in setdiff(tags, names(style[[1]]))) { + style <- modify_style(style, tag, label) + } + + # Find out if label style allows for recolouring, early exit if it doesn't + if (!any(c("colour", "fill") %in% names(key))) { + return(style) + } + + # Find out which keys are represented in text + idx <- which(vapply( + paste0("{.", tags, " "), + grepl, x = text[1], fixed = TRUE, + FUN.VALUE = logical(1) + )) + + if (length(idx) == 0) { + return(style) + } + + # Populate re-coloured parameters + key_color <- key$colour %||% key$fill + n <- nrow(key) + + fields <- c("color", "border", "background") + for (i in idx) { + # Set default fields to key color + args <- style[[1]][[tags[i]]][fields] + nms <- setdiff(fields, names(args)[lengths(args) > 0]) + args[nms] <- key_color[i] + # Recolour label's style + style <- modify_style(style, tag = tags[i], !!!args) + } + style +} From d02b1db73ca69038b82d391bb8e397d1dfd91781 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Jun 2024 11:51:41 +0200 Subject: [PATCH 3/9] document --- NAMESPACE | 1 + R/guide_marquee.R | 114 +++++++++++++++++++++++++++++++++++++ man/GuideMarquee.Rd | 13 +++++ man/guide_marquee.Rd | 132 +++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 260 insertions(+) create mode 100644 man/GuideMarquee.Rd create mode 100644 man/guide_marquee.Rd diff --git a/NAMESPACE b/NAMESPACE index a57100d..9f73992 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -29,6 +29,7 @@ S3method(widthDetails,marquee_grob) S3method(xDetails,marquee_grob) S3method(yDetails,marquee_grob) export(GeomMarquee) +export(GuideMarquee) export(base_style) export(classic_style) export(element_marquee) diff --git a/R/guide_marquee.R b/R/guide_marquee.R index ae662ba..f05f200 100644 --- a/R/guide_marquee.R +++ b/R/guide_marquee.R @@ -1,3 +1,101 @@ +#' Marquee subtitle guide +#' +#' This legend appears similar to a subtitle and uses marquee syntax to typeset +#' the text and interpolate legend glyphs. +#' +#' @param title A single character string indicating the text to display. If +#' `NULL` the title is not shown. If [`waiver()`][ggplot2::waiver()] +#' (default), the name of the scale or the name specified in +#' [`labs()`][ggplot2::labs()] is used for the tyle. +#' @param style Either a [style_set][style_set()] to override style sets +#' inherited from the theme, or a [style][style()] for styling the labels +#' specifically. For `colour` or `fill` scales, the `color`, `background` and +#' `border` style properties are overridden when set as `NULL`, see examples. +#' @param detect Either `FALSE` to typeset entirely through syntax or `TRUE` to +#' automatically detect labels and apply. +#' @param override.aes A list specifying aesthetic parameters of the legend +#' keys. See details and examples in +#' [`?guide_legend`][ggplot2::guide_legend()]. +#' @inheritParams ggplot2::guide_legend +#' +#' @details +#' # Text formatting +#' +#' In addition to standard [marquee syntax][marquee_parse()], there is +#' additional syntax to make building a guide easier. In the text below, `n` +#' marks the `n`-th break in the scale, `label` represents any of the scale's +#' labels and `foo` represents arbitrary text. +#' +#' * `<>` or `<