diff --git a/NAMESPACE b/NAMESPACE index fafcdd4..9b52825 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,7 +11,6 @@ export(GizmoGrob) export(GizmoHistogram) export(GizmoStepcap) export(GuideColring) -export(GuideSubtitle) export(PrimitiveBox) export(PrimitiveBracket) export(PrimitiveFence) @@ -46,7 +45,6 @@ export(guide_axis_nested) export(guide_colbar) export(guide_colring) export(guide_colsteps) -export(guide_subtitle) export(key_auto) export(key_bins) export(key_log) diff --git a/R/guide_subtitle.R b/R/guide_subtitle.R deleted file mode 100644 index 8e95c9a..0000000 --- a/R/guide_subtitle.R +++ /dev/null @@ -1,338 +0,0 @@ -# Constructor ------------------------------------------------------------- - -#' Subtitle with coloured phrases -#' -#' This guides formats a piece of text with colours determined from the scale. -#' -#' @param title A `` containing text to use as subtitle. Text -#' formatting is discussed in details. -#' @param open,close A `` delimiter indicating where colour -#' formatting begins (`open`) and ends (`close`). -#' @inheritParams common_parameters -#' -#' @details -#' ## Text formatting -#' Chunks of text are formatted as follows: the title is chopped up into -#' pieces split by the `open` and `close` delimiters. When the `open` delimiter -#' is followed by an integer, that integer is matched up against the scale's -#' breaks. The piece of text between that `open` delimiter and the associated -#' `close` delimiter is that coloured with the break's colour. -#' -#' For example, in the title -#' `"A {.1 quick} brown {.3 fox} jumps over the {.2 lazy dog}."`, the word -#' `"quick"` is given the scale's first colour, `"fox"` is given the third -#' colour and `"lazy dog"` is given the second colour. The first space after -#' the integer index gets trimmed. -#' -#' When there is no text inside the braces other than the index, the scale's -#' labels are inserted as text. -#' -#' While implemented as a legend guide, it takes style options from the -#' `plot.subtitle` theme element. As it is not a true subtitle, there might -#' be complications if other guides co-occupy the `"top"` legend position. -#' -#' ## Right-to-left scripts -#' The typesetting of this guide is primitive and only concerns itself with -#' placing text pieces, not individual glyphs. The only consideration given -#' to right-to-left script is that a line is converted from LtR to RtL when -#' all pieces of text on a line contain characters from RtL character sets. -#' Bidirectional text is given no consideration within this function. Glyphs -#' that should have ligatures in normal text, but are in separate pieces will -#' probably not render as ligatures. The task of actually rendering what is -#' within pieces of text, is handled by the graphics device, which have varying -#' degrees of modern text feature support. The author of this function, -#' who only knows LtR natural languages, profusely apologises for this -#' inconvenience. -#' -#' @return A `` object. -#' @export -#' @family standalone guides -#' -#' @examples -#' # A standard plot -#' p <- ggplot(mpg, aes(displ, hwy, colour = factor(cyl))) + -#' geom_point() -#' -#' # Typical use case -#' p + scale_colour_discrete( -#' name = "Cars with {.1 four}, {.2 five}, {.3 six} or {.4 eight} cylinders.", -#' guide = "subtitle" -#' ) -#' -#' # If there is no text in between the delimiters, the scale's `labels` are -#' # substituted. -#' p + scale_colour_discrete( -#' labels = c("FOUR", "5", "Six", "foobar"), -#' name = "Cars with {.1}, {.2}, {.3} or {.4} cylinders.", -#' guide = "subtitle" -#' ) -#' -#' # Using different text delimiters -#' p + guides(colour = guide_subtitle( -#' "Cars with <1 four>, <2 five>, <3 six> or <4 eight> cylinders.", -#' open = "<", close = ">" -#' )) -#' -#' # # For use with \{ggtext\}, mix html with the open and closing delimiters. -#' # # Leave out the '\' before quotation marks, it didn't document without -#' # # these backslashes :( -#' # p + -#' # scale_colour_discrete( -#' # name = \"Cars with {.1}, {.2 five}, {.3} or {.4} cylinders.\", -#' # guide = "subtitle" -#' # ) + -#' # theme(plot.subtitle = ggtext::element_markdown()) -guide_subtitle <- function( - title = waiver(), - open = "{.", - close = "}", - theme = NULL -) { - check_string(open) - check_string(close) - - new_guide( - title = title, - open = open, - close = close, - available_aes = c("colour", "fill"), - order = 1, - position = "top", - theme = theme, - super = GuideSubtitle - ) -} - -# Class ------------------------------------------------------------------- - -#' @export -#' @rdname gguidance_extensions -#' @format NULL -#' @usage NULL -GuideSubtitle <- ggproto( - "GuideSubtitle", Guide, - - params = new_params(open = "{.", close = "}"), - - elements = list(title = "plot.subtitle", spacing = "legend.box.spacing"), - - extract_params = function(scale, params, title = waiver(), ...) { - params$title <- scale$make_title(params$title %|W|% scale$name %|W|% title) - check_string(params$title, allow_null = TRUE, arg = "title") - params - }, - - setup_elements = function(params, elements, theme) { - theme <- theme + params$theme - title <- calc_element("plot.subtitle", theme) - spacing <- calc_element("legend.box.spacing", theme) - i <- match(opposite_position(params$position), .trbl) - title$margin[i] <- title$margin[i] - spacing - title - }, - - draw = function(self, theme, position = NULL, direction = NULL, - params = self$params) { - - direction <- params$direction %||% direction %||% - switch(position, top = , bottom = "horizontal", "vertical") - - params <- replace_null(params, position = position, direction = direction) - elem <- self$setup_elements(params, self$elements, theme) - - # Extract parameters - open <- params$open - close <- params$close - key <- params$key - - # Process string - chunks <- chunk_string(params$title, open, close) - string <- chunks$string - - # Remove open and close tokens - i <- chunks$depth > 0 - string[i] <- clean_tokens(string[i], open, close) - - # Match chunks to key - i <- !duplicated(chunks$group) & chunks$depth > 0 - matches <- rep(0, nrow(chunks)) - matches[i] <- as.integer(matched_pattern(string[i], "^[0-9]+", "0")) - matches <- vec_ave(matches, chunks$group, max) - matches[matches > nrow(params$key)] <- NA - - # Clean matching integers from string - string[i] <- gsub("^[0-9]+[ ]{0,1}", "", string[i]) - - # Replace empty strings with key label - empty <- i & !nzchar(string) - string[empty] <- key$.label[matches[empty]] - matches[is.na(matches)] <- 0 - - # Setup text parameters - colours <- elem$colour - colours <- c(colours, key$colour %||% key$fill %||% rep(colours, nrow(key))) - colours <- colours[matches + 1] - - chunks$matches <- matches - chunks$colour <- colours - chunks$string <- string - - if (inherits(elem, c("element_markdown", "element_textbox"))) { - # We just let ggtext take care of this - grob <- element_grob(elem, label = format_ggtext(chunks, elem)) - } else { - grob <- typeset_chunks(chunks, elem) - } - - gt <- switch( - direction, - horizontal = - gtable(widths = unit(1, "npc"), heights = unit(height_cm(grob), "cm")), - vertical = - gtable(widths = unit(width_cm(grob), "cm"), heights = unit(1, "npc")) - ) - gt <- gtable_add_grob(gt, grob, t = 1, l = 1, clip = "off", name = "title_guide") - gt - } -) - -# Helpers ----------------------------------------------------------------- - -typeset_chunks <- function(chunks, element) { - if (element$angle != 0) { - cli::cli_warn("{.fn guide_subtitle} cannot typeset angled text.") - } - - hjust <- element$hjust - vjust <- element$vjust - - margin <- width_cm(element$margin[c(2, 4)]) - width <- get_text_dim_cm(chunks$string, element, "width") - - xmax <- vec_ave(width, chunks$line, cumsum) - xmin <- vec_ave(xmax, chunks$line, function(x) c(0, x[-length(x)])) - - width_line <- vec_ave(xmax, chunks$line, max) - width_max <- max(width_line) - - rtl <- grepl(rtl_charsets, chunks$string) - rtl <- vec_ave(rtl, chunks$line, all) - - x <- (xmax + xmin) / 2 + (width_max - width_line) * hjust - x[rtl] <- width_line[rtl] - x[rtl] - x <- margin[2] * (1 - hjust) - (margin[1] + width_max) * hjust + x - x <- unit(hjust, "npc") + unit(x, "cm") - - max_lines <- max(chunks$line) - ymin <- chunks$line - 1L - ymax <- max_lines - chunks$line - y <- ymax * (1 - vjust) - ymin * vjust - y <- unit(vjust, "npc") + unit(y, "lines") - - element_grob( - element, label = chunks$string, - x = x, y = y, - vjust = vjust, hjust = 0.5, - lineheight = element$lineheight * 1.2, - colour = chunks$colour, - margin_x = FALSE, margin_y = TRUE - ) -} - -chunk_string <- function(string, open = "{.", close = "}") { - - lines <- strsplit(string, "\n", fixed = TRUE)[[1]] - nchars <- nchar(lines) - - chunks <- character() - line_index <- integer() - - # Find positions of opening and closing tokens - open_list <- gregexpr(open, lines, fixed = TRUE) - close_list <- gregexpr(close, lines, fixed = TRUE) - - close_list <- lapply(close_list, function(x) x + x %@% "match.length" - 1L) - - for (line in seq_along(lines)) { - # Get opening and closing positions for this line - opening <- .subset2(open_list, line) - opening <- opening[opening > 0] - closing <- .subset2(close_list, line) - closing <- closing[closing > 0] - - # Include true line starts and ends as well - start <- sort(c(1, opening, closing + 1L)) - end <- sort(c(opening - 1L, closing, nchars[line])) - - # Split line into parts - parts <- substr(rep(lines[line], length(start)), start, end) - parts <- parts[nzchar(parts)] - - # Append parts to earlier parts and add line index - chunks <- c(chunks, parts) - line_index <- c(line_index, rep(line, length(parts))) - } - - # Annotate for every part whether it has a opening or closing token - has_open <- startsWith(chunks, open) - has_close <- endsWith(chunks, close) - # start <- seq_along(chunks) * 2L - 1L - - # Calculate nesting depths: - # increase after every opening, decrease after every closing - # cumulative sum gives depth - depth <- vec_interleave(as.numeric(has_open), as.numeric(has_close) * -1) - depth <- vec_ave(depth, rep(line_index, each = 2), cumsum) - - # Compute groups based on depth - # Chunks have the same group if interrupted by higher depth and groups are - # broken up by lower depths. For example if we have the following sequence - # of depths: - # 1 2 3 2 3 2 1 2 - # We have the following groups - # 1 2 4 2 5 2 1 3 - group <- rep(0, length(depth)) - max_group <- 0 - for (i in sort(unique(depth))) { - run <- rle(depth >= i) - run$values[run$values] <- seq_along(run$values[run$values]) + max_group - group <- group + rep(run$values, run$lengths) - max_group <- max(group) - } - group <- match_self(group) - start <- seq_along(chunks) * 2L - 1L - - data_frame0( - string = chunks, - line = line_index, - depth = depth[start], - group = group[start] - ) -} - -clean_tokens <- function(x, open, close) { - i <- startsWith(x, open) - x[i] <- substr(x[i], nchar(open) + 1, nchar(x[i])) - i <- endsWith(x, close) - n <- nchar(x) - x[i] <- substr(x[i], 1, n[i] - nchar(close)) - x -} - -matched_pattern <- function(x, pattern, nomatch = "") { - found <- regexpr(pattern, x) - matched <- regmatches(x, found) - out <- rep(nomatch, length(x)) - out[found > 0] <- matched - out -} - -format_ggtext <- function(chunks, element) { - colours <- chunks$colour - strings <- chunks$string - main_colour <- element$colour - i <- chunks$depth > 0 & chunks$matches > 0 & colours != main_colour - strings[i] <- paste0("", strings[i], "") - text <- by_group(strings, chunks$line, paste0, collapse = "") - paste0(text, collapse = "
") -} diff --git a/man/gguidance_extensions.Rd b/man/gguidance_extensions.Rd index 8cc5601..07ab936 100644 --- a/man/gguidance_extensions.Rd +++ b/man/gguidance_extensions.Rd @@ -3,9 +3,9 @@ % R/compose-ontop.R, R/compose-sandwich.R, R/compose-stack.R, % R/gguidance-package.R, R/gizmo-barcap.R, R/gizmo-density.R, % R/gizmo-grob.R, R/gizmo-histogram.R, R/gizmo-stepcap.R, R/guide_colring.R, -% R/guide_subtitle.R, R/primitive-box.R, R/primitive-bracket.R, -% R/primitive-fence.R, R/primitive-labels.R, R/primitive-line.R, -% R/primitive-spacer.R, R/primitive-ticks.R, R/primitive-title.R +% R/primitive-box.R, R/primitive-bracket.R, R/primitive-fence.R, +% R/primitive-labels.R, R/primitive-line.R, R/primitive-spacer.R, +% R/primitive-ticks.R, R/primitive-title.R \docType{data} \name{Compose} \alias{Compose} @@ -20,7 +20,6 @@ \alias{GizmoHistogram} \alias{GizmoStepcap} \alias{GuideColring} -\alias{GuideSubtitle} \alias{PrimitiveBox} \alias{PrimitiveBracket} \alias{PrimitiveFence} diff --git a/man/guide_axis_custom.Rd b/man/guide_axis_custom.Rd index 5358ca5..7acd2e5 100644 --- a/man/guide_axis_custom.Rd +++ b/man/guide_axis_custom.Rd @@ -126,7 +126,6 @@ Other standalone guides: \code{\link{guide_axis_nested}()}, \code{\link{guide_colbar}()}, \code{\link{guide_colring}()}, -\code{\link{guide_colsteps}()}, -\code{\link{guide_subtitle}()} +\code{\link{guide_colsteps}()} } \concept{standalone guides} diff --git a/man/guide_axis_nested.Rd b/man/guide_axis_nested.Rd index c799146..d8cb73c 100644 --- a/man/guide_axis_nested.Rd +++ b/man/guide_axis_nested.Rd @@ -164,7 +164,6 @@ Other standalone guides: \code{\link{guide_axis_custom}()}, \code{\link{guide_colbar}()}, \code{\link{guide_colring}()}, -\code{\link{guide_colsteps}()}, -\code{\link{guide_subtitle}()} +\code{\link{guide_colsteps}()} } \concept{standalone guides} diff --git a/man/guide_colbar.Rd b/man/guide_colbar.Rd index ca4cd88..0fde24a 100644 --- a/man/guide_colbar.Rd +++ b/man/guide_colbar.Rd @@ -158,7 +158,6 @@ Other standalone guides: \code{\link{guide_axis_custom}()}, \code{\link{guide_axis_nested}()}, \code{\link{guide_colring}()}, -\code{\link{guide_colsteps}()}, -\code{\link{guide_subtitle}()} +\code{\link{guide_colsteps}()} } \concept{standalone guides} diff --git a/man/guide_colring.Rd b/man/guide_colring.Rd index 3ba9ecb..fa9596c 100644 --- a/man/guide_colring.Rd +++ b/man/guide_colring.Rd @@ -110,7 +110,6 @@ Other standalone guides: \code{\link{guide_axis_custom}()}, \code{\link{guide_axis_nested}()}, \code{\link{guide_colbar}()}, -\code{\link{guide_colsteps}()}, -\code{\link{guide_subtitle}()} +\code{\link{guide_colsteps}()} } \concept{standalone guides} diff --git a/man/guide_colsteps.Rd b/man/guide_colsteps.Rd index 451d27b..4c643b3 100644 --- a/man/guide_colsteps.Rd +++ b/man/guide_colsteps.Rd @@ -155,7 +155,6 @@ Other standalone guides: \code{\link{guide_axis_custom}()}, \code{\link{guide_axis_nested}()}, \code{\link{guide_colbar}()}, -\code{\link{guide_colring}()}, -\code{\link{guide_subtitle}()} +\code{\link{guide_colring}()} } \concept{standalone guides} diff --git a/man/guide_subtitle.Rd b/man/guide_subtitle.Rd deleted file mode 100644 index eeb4bb4..0000000 --- a/man/guide_subtitle.Rd +++ /dev/null @@ -1,107 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/guide_subtitle.R -\name{guide_subtitle} -\alias{guide_subtitle} -\title{Subtitle with coloured phrases} -\usage{ -guide_subtitle(title = waiver(), open = "{.", close = "}", theme = NULL) -} -\arguments{ -\item{title}{A \verb{} containing text to use as subtitle. Text -formatting is discussed in details.} - -\item{open, close}{A \verb{} delimiter indicating where colour -formatting begins (\code{open}) and ends (\code{close}).} - -\item{theme}{A \code{\link[ggplot2:theme]{}} object to style the guide individually or -differently from the plot's theme settings. The \code{theme} argument in the -guide overrides and is combined with the plot's theme.} -} -\value{ -A \verb{} object. -} -\description{ -This guides formats a piece of text with colours determined from the scale. -} -\details{ -\subsection{Text formatting}{ - -Chunks of text are formatted as follows: the title is chopped up into -pieces split by the \code{open} and \code{close} delimiters. When the \code{open} delimiter -is followed by an integer, that integer is matched up against the scale's -breaks. The piece of text between that \code{open} delimiter and the associated -\code{close} delimiter is that coloured with the break's colour. - -For example, in the title -\code{"A {.1 quick} brown {.3 fox} jumps over the {.2 lazy dog}."}, the word -\code{"quick"} is given the scale's first colour, \code{"fox"} is given the third -colour and \code{"lazy dog"} is given the second colour. The first space after -the integer index gets trimmed. - -When there is no text inside the braces other than the index, the scale's -labels are inserted as text. - -While implemented as a legend guide, it takes style options from the -\code{plot.subtitle} theme element. As it is not a true subtitle, there might -be complications if other guides co-occupy the \code{"top"} legend position. -} - -\subsection{Right-to-left scripts}{ - -The typesetting of this guide is primitive and only concerns itself with -placing text pieces, not individual glyphs. The only consideration given -to right-to-left script is that a line is converted from LtR to RtL when -all pieces of text on a line contain characters from RtL character sets. -Bidirectional text is given no consideration within this function. Glyphs -that should have ligatures in normal text, but are in separate pieces will -probably not render as ligatures. The task of actually rendering what is -within pieces of text, is handled by the graphics device, which have varying -degrees of modern text feature support. The author of this function, -who only knows LtR natural languages, profusely apologises for this -inconvenience. -} -} -\examples{ -# A standard plot -p <- ggplot(mpg, aes(displ, hwy, colour = factor(cyl))) + - geom_point() - -# Typical use case -p + scale_colour_discrete( - name = "Cars with {.1 four}, {.2 five}, {.3 six} or {.4 eight} cylinders.", - guide = "subtitle" -) - -# If there is no text in between the delimiters, the scale's `labels` are -# substituted. -p + scale_colour_discrete( - labels = c("FOUR", "5", "Six", "foobar"), - name = "Cars with {.1}, {.2}, {.3} or {.4} cylinders.", - guide = "subtitle" -) - -# Using different text delimiters -p + guides(colour = guide_subtitle( - "Cars with <1 four>, <2 five>, <3 six> or <4 eight> cylinders.", - open = "<", close = ">" -)) - -# # For use with \{ggtext\}, mix html with the open and closing delimiters. -# # Leave out the '\' before quotation marks, it didn't document without -# # these backslashes :( -# p + -# scale_colour_discrete( -# name = \"Cars with {.1}, {.2 five}, {.3} or {.4} cylinders.\", -# guide = "subtitle" -# ) + -# theme(plot.subtitle = ggtext::element_markdown()) -} -\seealso{ -Other standalone guides: -\code{\link{guide_axis_custom}()}, -\code{\link{guide_axis_nested}()}, -\code{\link{guide_colbar}()}, -\code{\link{guide_colring}()}, -\code{\link{guide_colsteps}()} -} -\concept{standalone guides} diff --git a/tests/testthat/_snaps/guide_subtitle/standard-subtitle-guide.svg b/tests/testthat/_snaps/guide_subtitle/standard-subtitle-guide.svg deleted file mode 100644 index 3213089..0000000 --- a/tests/testthat/_snaps/guide_subtitle/standard-subtitle-guide.svg +++ /dev/null @@ -1,96 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -100 -200 -300 -400 - - - - - - - - - - -10 -15 -20 -25 -30 -35 -mpg -disp -Cars with -four -, -eight - and -six - cylinders -standard subtitle guide - - diff --git a/tests/testthat/test-guide_subtitle.R b/tests/testthat/test-guide_subtitle.R deleted file mode 100644 index 2a438f3..0000000 --- a/tests/testthat/test-guide_subtitle.R +++ /dev/null @@ -1,50 +0,0 @@ -test_that("string chunking works as expected", { - - test <- chunk_string("foo\nbar") - expect_equal(test$string, c("foo", "bar")) - expect_equal(test$line, 1:2) - expect_equal(test$depth, c(0, 0)) - expect_equal(test$group, c(1, 1)) - - test <- chunk_string("foo{.bar}") - expect_equal(test$string, c("foo", "{.bar}")) - expect_equal(test$line, c(1, 1)) - expect_equal(test$depth, c(0, 1)) - expect_equal(test$group, c(1, 2)) - - string <- c("foo {.bar {.baz} qux {.quux} corge} grault {.garply}") - test <- chunk_string(string) - expect_equal( - test$string, - c("foo ", "{.bar ", "{.baz}", " qux ", "{.quux}", " corge}", " grault ", "{.garply}") - ) - expect_equal(test$line, rep(1L, 8)) - expect_equal(test$depth, c(0, 1, 2, 1, 2, 1, 0, 1)) - expect_equal(test$group, c(1, 2, 4, 2, 5, 2, 1, 3)) - -}) - -test_that("guide_subtitle works as intended", { - - p <- ggplot(mtcars, aes(mpg, disp, colour = factor(cyl))) + - geom_point() - - vdiffr::expect_doppelganger( - "standard subtitle guide", - p + scale_colour_discrete( - name = "Cars with {.1 four}, {.3 eight} and {.2 six} cylinders", - guide = "subtitle" - ) - ) - - # Should be the exact same as previous - vdiffr::expect_doppelganger( - "standard subtitle guide", - p + scale_colour_discrete( - name = "Cars with {.1}, {.3} and {.2} cylinders", - labels = c("four", "six", "eight"), - guide = "subtitle" - ) - ) - -})