From 55ef655e445744548e95d1068af521dbbc2ddd7f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 7 Sep 2024 09:26:19 +0200 Subject: [PATCH] revert #13 --- DESCRIPTION | 2 +- NAMESPACE | 4 - R/guide-legend-group.R | 471 ------------------ R/key-group.R | 146 ------ R/themes.R | 6 - R/utils-ggplot2.R | 31 -- R/utils-legends.R | 55 -- man/gguidance_extensions.Rd | 9 +- man/guide_legend_group.Rd | 95 ---- man/key_group.Rd | 81 --- man/key_range.Rd | 1 - man/key_specialty.Rd | 1 - man/key_standard.Rd | 1 - man/theme_guide.Rd | 4 - .../guide_legend_group/bottom-bottomtitle.svg | 127 ----- .../guide_legend_group/bottom-lefttitle.svg | 127 ----- .../guide_legend_group/bottom-righttitle.svg | 127 ----- .../guide_legend_group/bottom-toptitle.svg | 127 ----- .../guide_legend_group/right-bottomtitle.svg | 127 ----- .../guide_legend_group/right-lefttitle.svg | 127 ----- .../guide_legend_group/right-righttitle.svg | 127 ----- .../guide_legend_group/right-toptitle.svg | 127 ----- tests/testthat/test-guide_legend_group.R | 86 ---- tests/testthat/test-key-group.R | 64 --- 24 files changed, 5 insertions(+), 2068 deletions(-) delete mode 100644 R/guide-legend-group.R delete mode 100644 R/key-group.R delete mode 100644 R/utils-legends.R delete mode 100644 man/guide_legend_group.Rd delete mode 100644 man/key_group.Rd delete mode 100644 tests/testthat/_snaps/guide_legend_group/bottom-bottomtitle.svg delete mode 100644 tests/testthat/_snaps/guide_legend_group/bottom-lefttitle.svg delete mode 100644 tests/testthat/_snaps/guide_legend_group/bottom-righttitle.svg delete mode 100644 tests/testthat/_snaps/guide_legend_group/bottom-toptitle.svg delete mode 100644 tests/testthat/_snaps/guide_legend_group/right-bottomtitle.svg delete mode 100644 tests/testthat/_snaps/guide_legend_group/right-lefttitle.svg delete mode 100644 tests/testthat/_snaps/guide_legend_group/right-righttitle.svg delete mode 100644 tests/testthat/_snaps/guide_legend_group/right-toptitle.svg delete mode 100644 tests/testthat/test-guide_legend_group.R delete mode 100644 tests/testthat/test-key-group.R diff --git a/DESCRIPTION b/DESCRIPTION index d7d08c7..c90dde6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -12,7 +12,7 @@ Description: A 'ggplot2' extension that focusses on expanding the plotter's License: MIT + file LICENSE Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.2 Config/testthat/edition: 3 VignetteBuilder: knitr URL: https://teunbrand.github.io/gguidance/ diff --git a/NAMESPACE b/NAMESPACE index 9e109fd..7e9015c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,7 +11,6 @@ export(GizmoGrob) export(GizmoHistogram) export(GizmoStepcap) export(GuideColourRing) -export(GuideLegendGroup) export(GuideSubtitle) export(PrimitiveBox) export(PrimitiveBracket) @@ -45,12 +44,9 @@ export(guide_axis_custom) export(guide_colour_ring) export(guide_colourbar_custom) export(guide_coloursteps_custom) -export(guide_legend_group) export(guide_subtitle) export(key_auto) export(key_bins) -export(key_group_auto) -export(key_group_lut) export(key_log) export(key_manual) export(key_map) diff --git a/R/guide-legend-group.R b/R/guide-legend-group.R deleted file mode 100644 index 5517753..0000000 --- a/R/guide-legend-group.R +++ /dev/null @@ -1,471 +0,0 @@ -# Constructor ------------------------------------------------------------- - -#' Grouped legend -#' -#' A legend type guide similar to [`guide_legend()`][ggplot2::guide_legend()] -#' that allows for the indication of groups. -#' -#' @param key A [group key][key_group] specification. Defaults to -#' [`key_group_auto()`] that attempts to parse groups from labels. -#' @param override.aes A named `` specifying aesthetic parameters of -#' legend keys to override the defaults. See the examples in -#' [`?guide_legend`][ggplot2::guide_legend()]. -#' @param nrow,ncol An `` setting the desired number of rows and -#' columns of legend respectively, per group. -#' @inheritParams common_parameters -#' -#' @return A `` object. -#' @family legends -#' @export -#' -#' @examples -#' # Standard plot for selection of `msleep` -#' df <- msleep[c(9, 28, 11, 5, 34, 54, 64, 24, 53), ] -#' -#' p <- ggplot(df) + -#' aes(bodywt, awake, colour = paste(order, name)) + -#' geom_point() -#' -#' # By default, groups are inferred from the name -#' p + guides(colour = "legend_group") -#' -#' # You can also use a look-up table for groups -#' # The lookup table can be more expansive than just the data -#' lut <- key_group_lut(msleep$name, msleep$order) -#' -#' p + aes(colour = name) + -#' guides(colour = guide_legend_group(key = lut)) -#' -#' # `nrow` and `ncol` apply within groups -#' p + guides(colour = guide_legend_group(nrow = 1)) -#' -#' # Groups are arranged according to `direction` -#' p + guides(colour = guide_legend_group(ncol = 1, direction = "horizontal")) -#' -#' # Customising the group titles -#' p + guides(colour = "legend_group") + -#' theme( -#' gguidance.legend.subtitle.position = "left", -#' gguidance.legend.subtitle = element_text( -#' hjust = 1, vjust = 1, size = rel(0.9), -#' margin = margin(t = 5.5, r = 5.5) -#' ) -#' ) -#' -#' # Changing the spacing between groups -#' p + guides(colour = "legend_group") + -#' theme(gguidance.legend.group.spacing = unit(1, "cm")) -guide_legend_group <- function( - key = key_group_auto(), - title = waiver(), - override.aes = list(), - nrow = NULL, - ncol = NULL, - theme = NULL, - position = NULL, - direction = NULL, - order = 0 -) { - check_position(position, allow_null = TRUE) - check_argmatch(direction, c("horizontal", "vertical"), allow_null = TRUE) - check_number_whole(nrow, min = 1, allow_null = TRUE) - check_number_whole(ncol, min = 1, allow_null = TRUE) - check_exclusive(nrow, ncol) - - new_guide( - key = key, - title = title, - theme = theme, - override.aes = override.aes, - nrow = nrow, - ncol = ncol, - order = order, - available_aes = "any", - name = "legend_group", - direction = direction, - super = GuideLegendGroup - ) -} - - -# Class ------------------------------------------------------------------- - -#' @export -#' @rdname gguidance_extensions -#' @format NULL -#' @usage NULL -GuideLegendGroup <- ggproto( - "GuideLegendGroup", GuideLegend, - - params = c(GuideLegend$params, list(key = NULL)), - - elements = c( - GuideLegend$elements, - subtitle = "gguidance.legend.subtitle", - subtitle_position = "gguidance.legend.subtitle.position", - group_spacing = "gguidance.legend.group.spacing" - ), - - extract_key = function(scale, aesthetic, key, ...) { - key <- resolve_key(key %||% "group_auto") - if (is.function(key)) { - key <- key(scale, aesthetic) - } - if ("aesthetic" %in% names(key)) { - key$aesthetic <- - scale_transform(key$aesthetic, scale, map = TRUE, "aesthetic") - key$.value <- - scale_transform(key$.value, scale, map = FALSE, "value") - } - key <- rename(key, "aesthetic", aesthetic) - key <- validate_key_types(key) - check_columns(key, ".group") - - if (is.numeric(key$.value)) { - range <- scale$continuous_range %||% scale$get_limits() - key <- vec_slice(key, is.finite(oob_censor_any(key$.value, range))) - } - key - }, - - setup_params = function(params) { - check_argmatch( - params$direction, c("horizontal", "vertical"), - arg = "direction" - ) - - params$n_breaks <- n_breaks <- nrow(params$key) - params$n_key_layers <- length(params$decor) + 1 - - groups <- vec_count(params$key$.group) - groups <- vec_slice(groups, order(match(groups$key, params$key$.group))) - groups[c("nrow", "ncol")] <- resolve_legend_shape( - nrow = params$nrow, ncol = params$ncol, - n = groups$count, direction = params$direction - ) - params$groups <- groups - - if (params$direction == "horizontal") { - params$ncol <- sum(groups$ncol) - params$nrow <- max(groups$nrow) - } else { - params$ncol <- max(groups$ncol) - params$nrow <- sum(groups$nrow) - } - params - }, - - setup_elements = function(params, elements, theme) { - - theme <- theme + params$theme - sub_position <- calc_element("gguidance.legend.subtitle.position", theme) - check_position(sub_position, .trbl, arg = "gguidance.legend.subtitle.position") - gap <- theme$legend.key.spacing <- calc_element("legend.key.spacing", theme) - - margin <- calc_element("text", theme)$margin - text <- theme(text = element_text( - hjust = 0, vjust = 0.5, - margin = position_margin(sub_position, margin, gap * 0.5) - )) - elements$subtitle <- calc_element(elements$subtitle, theme + text) - elements$spacing_y <- calc_element(elements$spacing_y, theme) - theme <- replace_null( - theme, - legend.title.position = "top" - ) - GuideLegend$setup_elements(params, elements, theme) - }, - - build_title = function(label, elements, params) { - main <- element_grob( - elements$title, label = label, - margin_x = TRUE, margin_y = TRUE - ) - main$name <- grobName(main, "guide.title") - subtitle <- lapply( - params$groups$key, - function(lab) { - sub <- element_grob( - elements$subtitle, label = lab, - margin_x = TRUE, margin_y = TRUE - ) - sub$name <- grobName(sub, "guide.subtitle") - sub - } - ) - c(list(main), subtitle) - }, - - measure_grobs = function(grobs, params, elements) { - - key <- params$key - n_layers <- params$n_key_layers - - key_widths <- get_key_size(grobs$decor, "width", nrow(key)) - key_heights <- get_key_size(grobs$decor, "height", nrow(key)) - - key_widths <- pmax(key_widths, width_cm(elements$key_width)) - key_heights <- pmax(key_heights, height_cm(elements$key_height)) - - lab_widths <- width_cm(grobs$labels) - lab_heights <- height_cm(grobs$labels) - - groups <- params$groups - n_groups <- nrow(groups) - - ncol <- rep(groups$ncol, groups$count) - nrow <- rep(groups$nrow, groups$count) - - break_seq <- seq_len(sum(groups$count)) - break_seq <- vec_ave(break_seq, key$.group, seq_along) - - if (elements$byrow %||% FALSE) { - row <- ceiling(break_seq / ncol) - col <- (break_seq - 1L) %% ncol + 1 - } else { - row <- (break_seq - 1L) %% nrow + 1 - col <- ceiling(break_seq / nrow) - } - - if (params$direction == "vertical") { - row <- row + rep(cumsum(c(0, groups$nrow[-n_groups])), groups$count) - } else { - col <- col + rep(cumsum(c(0, groups$ncol[-n_groups])), groups$count) - } - key$row <- row - key$col <- col - - key_heights <- by_group(key_heights, row, max) - lab_heights <- by_group(lab_heights, row, max) - key_widths <- by_group(key_widths, col, max) - lab_widths <- by_group(lab_widths, col, max) - - position <- elements$text_position - - hgap <- elements$spacing_x - widths <- switch( - position, - left = list(lab_widths, key_widths, hgap), - right = list(key_widths, lab_widths, hgap), - list(pmax(lab_widths, key_widths), hgap) - ) - - widths <- vec_interleave(!!!widths) - widths <- widths[-length(widths)] - - vgap <- elements$spacing_y - heights <- switch( - position, - top = list(lab_heights, key_heights, vgap), - bottom = list(key_heights, lab_heights, vgap), - list(pmax(lab_heights, key_heights), vgap) - ) - heights <- vec_interleave(!!!heights) - heights <- heights[-length(heights)] - - subtitles <- grobs$title[-1] - subtitle_width <- width_cm(subtitles) - subtitle_height <- height_cm(subtitles) - - just <- with(elements$subtitle, rotate_just(angle, hjust, vjust)) - - list( - key = key, - widths = widths, - heights = heights, - padding = elements$padding, - label_position = elements$text_position, - title_position = elements$title_position, - subtitle_position = elements$subtitle_position, - subtitle_height = subtitle_height, - subtitle_width = subtitle_width, - subtitle_just = just, - group_spacing = height_cm(elements$group_spacing), - groups = groups - ) - }, - - arrange_layout = function(key, sizes, params, elements) { - - key <- sizes$key - row <- key$row - col <- key$col - - key_row <- row * 2 - 1 - key_col <- col * 2 - 1 - - position <- sizes$label_position - key_row <- key_row + switch(position, top = row, bottom = row - 1, 0) - lab_row <- key_row + switch(position, top = -1, bottom = 1, 0) - key_col <- key_col + switch(position, left = col, right = col - 1, 0) - lab_col <- key_col + switch(position, left = -1, right = 1, 0) - - group <- as.integer(key$.group) - - t <- by_group(pmin(key_row, lab_row), group, min) - b <- by_group(pmax(key_row, lab_row), group, max) - l <- by_group(pmin(key_col, lab_col), group, min) - r <- by_group(pmax(key_col, lab_col), group, max) - - top_aligned <- all(t == t[1]) - left_aligned <- all(l == l[1]) - - position <- sizes$subtitle_position - widths <- sizes$widths - heights <- sizes$heights - sub_width <- by_group(sizes$subtitle_width, l, max) - sub_height <- by_group(sizes$subtitle_height, t, max) - spacing <- sizes$group_spacing - - row_add <- 0 - col_add <- 0 - - if (position == "bottom" && all(t == t[1])) { - b <- rep(max(b), length(b)) - } - if (position == "right" && all(l == l[1])) { - r <- rep(max(r), length(r)) - } - - var <- switch(position, top = t, left = l, bottom = b, right = r) - uni <- unique(var) - size <- switch(position, top = , bottom = heights, widths) - - if (position == "top") { - size <- insert_before(size, uni, sub_height) - row_add <- findInterval(key_row, uni) - } else if (position == "left") { - size <- insert_before(size, uni, sub_width) - col_add <- findInterval(key_col, uni) - } else if (position == "bottom") { - size <- insert_after(size, uni, sub_height) - row_add <- findInterval(key_row, uni, left.open = TRUE) - } else if (position == "right") { - size <- insert_after(size, uni, sub_width) - col_add <- findInterval(key_col, uni, left.open = TRUE) - } - - var <- var + match(var, uni) - as.numeric(position %in% c("top", "left")) - n <- switch(position, left = , top = c(1, -1), c(length(size), 1)) - size[setdiff(var, n[1]) + n[2]] <- spacing - - if (position %in% c("top", "bottom")) { - t <- b <- var - heights <- size - if (all(t == t[1])) { - widths[setdiff(unique(l), 1) - 1] <- spacing - } - if (all(l == l[1])) { - r <- rep(max(r), length(r)) - } - cum_width <- cumsum(widths) - ur <- unique(r) - ul <- unique(l) - - extra_width <- pmax(0, sub_width - (cum_width[ur] - c(0, cum_width)[ul])) - hjust <- sizes$subtitle_just$hjust * c(1, -1) + c(0, 1) - - m <- match(ul, ul) - index <- seq_along(widths) - new_index <- insert_before(index, ul, NA) - new_index <- insert_after(new_index, ur + m, NA) - index <- match(index, new_index) - - widths <- insert_before(widths, ul, extra_width * hjust[1]) - widths <- insert_after(widths, ur + m, extra_width * hjust[2]) - - key_col <- index[key_col] - lab_col <- index[lab_col] - l <- index[l] - 1 - r <- index[r] + 1 - } else { - l <- r <- var - widths <- size - if (all(l == l[1])) { - heights[setdiff(unique(t), 1) - 1] <- spacing - } - if (all(t == t[1])) { - b <- rep(max(b), length(b)) - } - cum_height <- cumsum(heights) - ut <- unique(t) - ub <- unique(b) - - extra_height <- pmax(0, sub_height - (cum_height[ub] - c(0, cum_height)[ut])) - vjust <- sizes$subtitle_just$vjust * c(1, -1) + c(0, 1) - - m <- match(ut, ut) - index <- seq_along(heights) - new_index <- insert_before(index, ut, NA) - new_index <- insert_after(new_index, ub + m, NA) - index <- match(index, new_index) - - heights <- insert_before(heights, ut, extra_height * vjust[2]) - heights <- insert_after(heights, ub + m, extra_height * vjust[1]) - - key_row <- index[key_row] - lab_row <- index[lab_row] - t <- index[t] - 1 - b <- index[b] + 1 - } - - key_row <- key_row + row_add - lab_row <- lab_row + row_add - key_col <- key_col + col_add - lab_col <- lab_col + col_add - - groups <- sizes$groups - groups[, c("t", "r", "b", "l")] <- list(t, r, b, l) - - df <- cbind(key, key_row, key_col, label_row = lab_row, label_col = lab_col) - list(layout = df, groups = groups, heights = heights, widths = widths) - }, - - assemble_drawing = function(self, grobs, layout, sizes, params, elements) { - - subtitles <- grobs$title[-1] - grobs$title <- grobs$title[[1]] - groups <- layout$groups - - gt <- legend_assemble( - unit(layout$widths, "cm"), unit(layout$heights, "cm"), - layout$layout, grobs, elements, params$n_key_layers - ) - - gt <- gtable_add_grob( - gt, subtitles, - t = groups$t, l = groups$l, r = groups$r, b = groups$b, - name = paste0("subtitle-", seq_len(nrow(groups))) - ) - - gt <- self$add_title( - gt, grobs$title, elements$title_position, - with(elements$title, rotate_just(angle, hjust, vjust)) - ) - gt <- gtable_add_padding(gt, elements$margin) - gt <- legend_add_background(gt, elements$background) - gt - } -) - -resolve_legend_shape <- function(nrow, ncol, n, direction) { - if (!is.null(nrow) && !is.null(ncol) && - nrow * ncol < n) { - cli::cli_abort(paste0( - "{.arg nrow} * {.arg ncol} needs to be larger than the number of ", - "breaks ({n})." - )) - } - if (is.null(nrow) && is.null(ncol)) { - if (direction == "horizontal") { - nrow <- ceiling(n / 5) - } else { - ncol <- ceiling(n / 20) - } - } - nrow <- nrow %||% ceiling(n / ncol) - ncol <- ceiling(n / nrow) - list(nrow = nrow, ncol = ncol) -} - - diff --git a/R/key-group.R b/R/key-group.R deleted file mode 100644 index a5d788a..0000000 --- a/R/key-group.R +++ /dev/null @@ -1,146 +0,0 @@ -# Group keys -------------------------------------------------------------- - -#' Group keys -#' -#' @description -#' These functions are helper function for working with grouped data as keys in -#' guides. They all share the goal of creating a guide key, but have different -#' methods. -#' -#' * `key_group_auto()` is a function factory whose functions make an attempt -#' to infer groups from the scale's labels. -#' * `key_group_lut()` is a function factory whose functions use a look up table -#' to sort out group membership. -#' -#' @param sep A `` giving a [regular expression][base::regex] to -#' use for splitting labels provided by the scale using -#' [`strsplit()`][base::strsplit]. Defaults to splitting on any -#' non-alphanumeric character. -#' @param reverse A `` which if `FALSE` (default) treats the first -#' part of the split string as groups, and if `TRUE` treats the last part -#' as groups. -#' @param members A vector including the scale's `breaks` values. -#' @param group A vector parallel to `members` giving the group of every member. -#' @param ungrouped A `` giving a group label to assign to the -#' scale's `breaks` that match no values in the `members` argument. -#' -#' @details -#' The resulting key is always sorted by group. -#' The `key_group_auto()` does *not* work with expression labels. -#' -#' @name key_group -#' @family keys -#' @return -#' For `key_group_auto()` and `key_group_lut()`, a function. -#' -#' @examples -#' # Example scale -#' values <- c("group A:value 1", "group A:value 2", "group B:value 1") -#' template <- scale_colour_discrete(limits = values) -#' -#' # Treat the 'group X' part as groups -#' auto <- key_group_auto(sep = ":") -#' auto(template) -#' -#' # Treat the 'value X' part as groups -#' auto <- key_group_auto(sep = ":", reverse = TRUE) -#' auto(template) -#' -#' # Example scale -#' template <- scale_colour_discrete(limits = msleep$name[c(1, 7, 9, 23, 24)]) -#' -#' # A lookup table can have more entries than needed -#' lut <- key_group_lut(msleep$name, msleep$order) -#' lut(template) -#' -#' # Or less entries than needed -#' lut <- key_group_lut( -#' msleep$name[23:24], msleep$order[23:24], -#' ungrouped = "Other animals" -#' ) -#' lut(template) -NULL - -#' @rdname key_group -#' @export -key_group_auto <- function(sep = "[^[:alnum:]]+", reverse = FALSE) { - check_string(sep) - check_bool(reverse) - force(sep) - force(reverse) - call <- current_call() - function(scale, aesthetic = NULL) { - group_from_label( - scale = scale, aesthetic = aesthetic, - sep = sep, reverse = reverse, - call = call - ) - } -} - -#' @rdname key_group -#' @export -key_group_lut <- function(members, group, ungrouped = "Other") { - check_string(ungrouped) - check_unique(members) - if (length(group) != length(members)) { - cli::cli_abort(c( - "{.arg group} must have the same length as {.arg members}.", - i = "{.arg group} has length {length(group)}.", - i = "{.arg members} has length {length(members)}." - )) - } - lut <- vec_split(members, group) - - function(scale, aesthetic = NULL) { - group_from_lut( - scale = scale, aesthetic = aesthetic, - lut = lut, ungrouped = ungrouped - ) - } -} - -# Helpers ----------------------------------------------------------------- - -group_from_lut <- function(scale, aesthetic, lut, ungrouped = "Other") { - aesthetic <- aesthetic %||% scale$aesthetics[1] - key <- Guide$extract_key(scale, aesthetic) - group <- lut$key[match_list(key$.value, lut$val)] %|NA|% ungrouped - if (!is.factor(group)) { - group <- factor(group, c(setdiff(unique(group), ungrouped), ungrouped)) - } - key$.group <- group - vec_slice(key, order(group)) -} - -group_from_label <- function(scale, aesthetic, sep = "[^[:alnum:]]+", - reverse = FALSE, call = call) { - # Extract a standard key from the scale - aesthetic <- aesthetic %||% scale$aesthetics[1] - key <- Guide$extract_key(scale, aesthetic) - - # Reject expressions, as we cannot split these - if (!is.character(key$.label)) { - type <- obj_type_friendly(key$.label) - cli::cli_abort( - c("Cannot split the guide's {.field label}.", - i = "It must be a {.cls character} vector, not {type}."), - call = call - ) - } - - labels <- strsplit(key$.label, sep) - if (isTRUE(reverse)) { - i <- lengths(labels) - } else { - i <- rep(1L, length(labels)) - } - - groups <- vec_c(!!!Map(vec_slice, i = i, x = labels)) - labels <- lapply(Map(vec_slice, i = -i, x = labels), paste0, collapse = " ") - labels <- vec_c(!!!labels) - - key$.label <- labels - key$.group <- factor(groups, unique(groups)) - vec_slice(key, order(key$.group)) -} diff --git a/R/themes.R b/R/themes.R index eab1923..f12b88a 100644 --- a/R/themes.R +++ b/R/themes.R @@ -38,8 +38,6 @@ #' `gguidance.legend.mini.ticks.length`. #' @param spacing A [``][grid::unit()] setting the #' `gguidance.guide.spacing` theme element. -#' @param group.spacing A [``][grid::unit()] setting the -#' `gguidance.legend.group.spacing` element. #' @param key An [``][ggplot2::element_rect] setting the #' `legend.key` element. #' @param key.size,key.width,key.height A [``][grid::unit()] setting the @@ -95,7 +93,6 @@ theme_guide <- function( mini.ticks.length = NULL, spacing = NULL, - group.spacing = NULL, key = NULL, key.size = NULL, @@ -158,7 +155,6 @@ theme_guide <- function( gguidance.legend.mini.ticks.length = mini.ticks.length, gguidance.guide.spacing = spacing, - gguidance.legend.group.spacing = group.spacing, legend.key = key, legend.key.spacing = key.spacing, @@ -190,7 +186,6 @@ register_gguidance_elements <- function() { gguidance.legend.mini.ticks.length = rel(0.5), gguidance.legend.subtitle = element_text(size = rel(0.9)), gguidance.legend.subtitle.position = "top", - gguidance.legend.group.spacing = rel(2), gguidance.axis.mini.ticks = element_line(), gguidance.axis.mini.ticks.length = rel(0.5), gguidance.guide.spacing = unit(2.25, "pt"), @@ -206,7 +201,6 @@ register_gguidance_elements <- function() { gguidance.legend.mini.ticks.length = el_unit("gguidance.legend.minor.ticks.length"), gguidance.legend.subtitle = el_def("element_text", "legend.title"), gguidance.legend.subtitle.position = el_def("character"), - gguidance.legend.group.spacing = el_unit("legend.key.spacing"), gguidance.axis.mini.ticks = el_line("axis.ticks"), gguidance.axis.mini.ticks.length = el_unit("axis.minor.ticks.length"), gguidance.guide.spacing = el_unit("axis.ticks.length"), diff --git a/R/utils-ggplot2.R b/R/utils-ggplot2.R index 51d1a5f..5d95c01 100644 --- a/R/utils-ggplot2.R +++ b/R/utils-ggplot2.R @@ -256,35 +256,4 @@ in_arc <- function(theta, arc) { } } -set_key_size <- function(key, linewidth = NULL, size = NULL, default = NULL) { - if (!is.null(attr(key, "width")) && !is.null(attr(key, "height"))) { - return(key) - } - if (!is.null(size) || !is.null(linewidth)) { - size <- size %||% 0 - lwd <- linewidth %||% 0 - size <- if (is.na(size)[1]) 0 else size[1] - lwd <- if (is.na(lwd)[1]) 0 else linewidth[1] - size <- (size + lwd) / 10 - } else { - size <- NULL - } - attr(key, "width") <- attr(key, "width", TRUE) %||% size %||% default[1] - attr(key, "height") <- attr(key, "height", TRUE) %||% size %||% default[2] - key -} - -modify_list <- function(old, new) { - for (i in names(new)) old[[i]] <- new[[i]] - old -} - -allow_lambda <- function(x) { - if (is_formula(x)) { - as_function(x) - } else { - x - } -} - # nocov end diff --git a/R/utils-legends.R b/R/utils-legends.R deleted file mode 100644 index d9d7cc9..0000000 --- a/R/utils-legends.R +++ /dev/null @@ -1,55 +0,0 @@ - -legend_assemble <- function( - widths, heights, - layout, grobs, elements, - n_layers = 1 -) { - - if (isTRUE(elements$stretch_x)) { - widths[unique(layout$key_col)] <- elements$key_width - } - - if (isTRUE(elements$stretch_y)) { - heights[unique(layout$key_row)] <- elements$key_height - } - - gt <- gtable(widths = widths, heights = heights) - - if (!is.zero(grobs$decor)) { - cols <- rep(layout$key_col, each = n_layers) - rows <- rep(layout$key_row, each = n_layers) - names <- names(grobs$decor) %||% - paste("key", rows, cols, c("bg", seq_len(n_layers - 1)), sep = "-") - gt <- gtable_add_grob( - gt, grobs$decor, - name = names, clip = "off", - t = rows, r = cols, b = rows, l = cols - ) - } - - if (!is.zero(grobs$labels)) { - rows <- layout$label_row - cols <- layout$label_col - names <- names(grobs$labels) %||% paste("label", rows, cols, sep = "-") - gt <- gtable_add_grob( - gt, grobs$labels, - name = names, clip = "off", - t = rows, r = cols, b = rows, l = cols - ) - } - return(gt) -} - -legend_add_background <- function(gt, background) { - if (inherits(background, "element")) { - background <- element_grob(background) - } - if (is.zero(background) || is.null(background)) { - return(gt) - } - gt <- gtable_add_grob( - gt, background, name = "background", clip = "off", - t = 1, r = -1, b = -1, l = 1, z = -Inf - ) - gt -} diff --git a/man/gguidance_extensions.Rd b/man/gguidance_extensions.Rd index 15356a8..6f3c2a5 100644 --- a/man/gguidance_extensions.Rd +++ b/man/gguidance_extensions.Rd @@ -2,10 +2,10 @@ % Please edit documentation in R/compose-.R, R/compose-crux.R, % 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-legend-group.R, -% R/guide_colour_ring.R, R/guide_subtitle.R, R/primitive-box.R, -% R/primitive-bracket.R, R/primitive-labels.R, R/primitive-line.R, -% R/primitive-spacer.R, R/primitive-ticks.R, R/primitive-title.R +% R/gizmo-histogram.R, R/gizmo-stepcap.R, R/guide_colour_ring.R, +% R/guide_subtitle.R, R/primitive-box.R, R/primitive-bracket.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} @@ -19,7 +19,6 @@ \alias{GizmoGrob} \alias{GizmoHistogram} \alias{GizmoStepcap} -\alias{GuideLegendGroup} \alias{GuideColourRing} \alias{GuideSubtitle} \alias{PrimitiveBox} diff --git a/man/guide_legend_group.Rd b/man/guide_legend_group.Rd deleted file mode 100644 index d11c234..0000000 --- a/man/guide_legend_group.Rd +++ /dev/null @@ -1,95 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/guide-legend-group.R -\name{guide_legend_group} -\alias{guide_legend_group} -\title{Grouped legend} -\usage{ -guide_legend_group( - key = key_group_auto(), - title = waiver(), - override.aes = list(), - nrow = NULL, - ncol = NULL, - theme = NULL, - position = NULL, - direction = NULL, - order = 0 -) -} -\arguments{ -\item{key}{A \link[=key_group]{group key} specification. Defaults to -\code{\link[=key_group_auto]{key_group_auto()}} that attempts to parse groups from labels.} - -\item{title}{A \verb{} or \verb{} indicating the title of -the guide. If \code{NULL}, the title is not shown. The default, -\code{\link[ggplot2:waiver]{waiver()}}, takes the name of the scale object or -the name specified in \code{\link[ggplot2:labs]{labs()}} as the title.} - -\item{override.aes}{A named \verb{} specifying aesthetic parameters of -legend keys to override the defaults. See the examples in -\code{\link[ggplot2:guide_legend]{?guide_legend}}.} - -\item{nrow, ncol}{An \verb{} setting the desired number of rows and -columns of legend respectively, per group.} - -\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.} - -\item{position}{A \verb{} giving the location of the guide. Can be one of \code{"top"}, -\code{"bottom"}, \code{"left"} or \code{"right"}.} - -\item{direction}{A \verb{} indicating the direction of the guide. Can be on of -\code{"horizontal"} or \code{"vertical"}.} - -\item{order}{A positive \verb{} that specifies the order of this guide among -multiple guides. This controls in which order guides are merged if there -are multiple guides for the same position. If \code{0} (default), the order is -determined by a hashing indicative settings of a guide.} -} -\value{ -A \verb{} object. -} -\description{ -A legend type guide similar to \code{\link[ggplot2:guide_legend]{guide_legend()}} -that allows for the indication of groups. -} -\examples{ -# Standard plot for selection of `msleep` -df <- msleep[c(9, 28, 11, 5, 34, 54, 64, 24, 53), ] - -p <- ggplot(df) + - aes(bodywt, awake, colour = paste(order, name)) + - geom_point() - -# By default, groups are inferred from the name -p + guides(colour = "legend_group") - -# You can also use a look-up table for groups -# The lookup table can be more expansive than just the data -lut <- key_group_lut(msleep$name, msleep$order) - -p + aes(colour = name) + - guides(colour = guide_legend_group(key = lut)) - -# `nrow` and `ncol` apply within groups -p + guides(colour = guide_legend_group(nrow = 1)) - -# Groups are arranged according to `direction` -p + guides(colour = guide_legend_group(ncol = 1, direction = "horizontal")) - -# Customising the group titles -p + guides(colour = "legend_group") + - theme( - gguidance.legend.subtitle.position = "left", - gguidance.legend.subtitle = element_text( - hjust = 1, vjust = 1, size = rel(0.9), - margin = margin(t = 5.5, r = 5.5) - ) - ) - -# Changing the spacing between groups -p + guides(colour = "legend_group") + - theme(gguidance.legend.group.spacing = unit(1, "cm")) -} -\concept{legends} diff --git a/man/key_group.Rd b/man/key_group.Rd deleted file mode 100644 index f2d2c15..0000000 --- a/man/key_group.Rd +++ /dev/null @@ -1,81 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/key-group.R -\name{key_group} -\alias{key_group} -\alias{key_group_auto} -\alias{key_group_lut} -\title{Group keys} -\usage{ -key_group_auto(sep = "[^[:alnum:]]+", reverse = FALSE) - -key_group_lut(members, group, ungrouped = "Other") -} -\arguments{ -\item{sep}{A \verb{} giving a \link[base:regex]{regular expression} to -use for splitting labels provided by the scale using -\code{\link[base:strsplit]{strsplit()}}. Defaults to splitting on any -non-alphanumeric character.} - -\item{reverse}{A \verb{} which if \code{FALSE} (default) treats the first -part of the split string as groups, and if \code{TRUE} treats the last part -as groups.} - -\item{members}{A vector including the scale's \code{breaks} values.} - -\item{group}{A vector parallel to \code{members} giving the group of every member.} - -\item{ungrouped}{A \verb{} giving a group label to assign to the -scale's \code{breaks} that match no values in the \code{members} argument.} -} -\value{ -For \code{key_group_auto()} and \code{key_group_lut()}, a function. -} -\description{ -These functions are helper function for working with grouped data as keys in -guides. They all share the goal of creating a guide key, but have different -methods. -\itemize{ -\item \code{key_group_auto()} is a function factory whose functions make an attempt -to infer groups from the scale's labels. -\item \code{key_group_lut()} is a function factory whose functions use a look up table -to sort out group membership. -} -} -\details{ -The resulting key is always sorted by group. -The \code{key_group_auto()} does \emph{not} work with expression labels. -} -\examples{ -# Example scale -values <- c("group A:value 1", "group A:value 2", "group B:value 1") -template <- scale_colour_discrete(limits = values) - -# Treat the 'group X' part as groups -auto <- key_group_auto(sep = ":") -auto(template) - -# Treat the 'value X' part as groups -auto <- key_group_auto(sep = ":", reverse = TRUE) -auto(template) - -# Example scale -template <- scale_colour_discrete(limits = msleep$name[c(1, 7, 9, 23, 24)]) - -# A lookup table can have more entries than needed -lut <- key_group_lut(msleep$name, msleep$order) -lut(template) - -# Or less entries than needed -lut <- key_group_lut( - msleep$name[23:24], msleep$order[23:24], - ungrouped = "Other animals" -) -lut(template) -} -\seealso{ -Other keys: -\code{\link{key_range}}, -\code{\link{key_specialty}}, -\code{\link{key_standard}} -} -\concept{keys} diff --git a/man/key_range.Rd b/man/key_range.Rd index ce707a2..3de780d 100644 --- a/man/key_range.Rd +++ b/man/key_range.Rd @@ -94,7 +94,6 @@ key_range_map(presidential, start = start, end = end, name = name) } \seealso{ Other keys: -\code{\link{key_group}}, \code{\link{key_specialty}}, \code{\link{key_standard}} } diff --git a/man/key_specialty.Rd b/man/key_specialty.Rd index 067cc88..87e703b 100644 --- a/man/key_specialty.Rd +++ b/man/key_specialty.Rd @@ -50,7 +50,6 @@ key_bins()(template) } \seealso{ Other keys: -\code{\link{key_group}}, \code{\link{key_range}}, \code{\link{key_standard}} } diff --git a/man/key_standard.Rd b/man/key_standard.Rd index 8689955..efedafd 100644 --- a/man/key_standard.Rd +++ b/man/key_standard.Rd @@ -114,7 +114,6 @@ key_map(ToothGrowth, aesthetic = unique(supp)) } \seealso{ Other keys: -\code{\link{key_group}}, \code{\link{key_range}}, \code{\link{key_specialty}} } diff --git a/man/theme_guide.Rd b/man/theme_guide.Rd index fa6b893..b0bf420 100644 --- a/man/theme_guide.Rd +++ b/man/theme_guide.Rd @@ -19,7 +19,6 @@ theme_guide( minor.ticks.length = NULL, mini.ticks.length = NULL, spacing = NULL, - group.spacing = NULL, key = NULL, key.size = NULL, key.width = NULL, @@ -81,9 +80,6 @@ theme_guide( \item{spacing}{A [\verb{}][grid::unit()] setting the \code{gguidance.guide.spacing} theme element.} -\item{group.spacing}{A [\verb{}][grid::unit()] setting the -\code{gguidance.legend.group.spacing} element.} - \item{key}{An \code{\link[ggplot2:element]{}} setting the \code{legend.key} element.} diff --git a/tests/testthat/_snaps/guide_legend_group/bottom-bottomtitle.svg b/tests/testthat/_snaps/guide_legend_group/bottom-bottomtitle.svg deleted file mode 100644 index 086e7e2..0000000 --- a/tests/testthat/_snaps/guide_legend_group/bottom-bottomtitle.svg +++ /dev/null @@ -1,127 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -12 -15 -18 -21 - - - - - - - - -0 -200 -400 -600 -bodywt -awake - -Animals - - - - - - - - - - - - - - - - -Cow -Goat -Dog -Domestic cat -Lion -Donkey -Baboon -Human - - - - - - - -Artiodactyla - - - - - - - - - -Carnivora - - - - - - - - - -Perissodactyla - - - - - - - - - -Primates - - -bottom-bottomtitle - - diff --git a/tests/testthat/_snaps/guide_legend_group/bottom-lefttitle.svg b/tests/testthat/_snaps/guide_legend_group/bottom-lefttitle.svg deleted file mode 100644 index 371ca6c..0000000 --- a/tests/testthat/_snaps/guide_legend_group/bottom-lefttitle.svg +++ /dev/null @@ -1,127 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -12 -15 -18 -21 - - - - - - - - -0 -200 -400 -600 -bodywt -awake - -Animals - - - - - - - - - - - - - - - - -Cow -Goat -Dog -Domestic cat -Lion -Donkey -Baboon -Human - - - - - - - -Artiodactyla - - - - - - - - - -Carnivora - - - - - - - - - -Perissodactyla - - - - - - - - - -Primates - - -bottom-lefttitle - - diff --git a/tests/testthat/_snaps/guide_legend_group/bottom-righttitle.svg b/tests/testthat/_snaps/guide_legend_group/bottom-righttitle.svg deleted file mode 100644 index 5bf2bc2..0000000 --- a/tests/testthat/_snaps/guide_legend_group/bottom-righttitle.svg +++ /dev/null @@ -1,127 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -12 -15 -18 -21 - - - - - - - - -0 -200 -400 -600 -bodywt -awake - -Animals - - - - - - - - - - - - - - - - -Cow -Goat -Dog -Domestic cat -Lion -Donkey -Baboon -Human - - - - - - - -Artiodactyla - - - - - - - - - -Carnivora - - - - - - - - - -Perissodactyla - - - - - - - - - -Primates - - -bottom-righttitle - - diff --git a/tests/testthat/_snaps/guide_legend_group/bottom-toptitle.svg b/tests/testthat/_snaps/guide_legend_group/bottom-toptitle.svg deleted file mode 100644 index 58ca98a..0000000 --- a/tests/testthat/_snaps/guide_legend_group/bottom-toptitle.svg +++ /dev/null @@ -1,127 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -12 -15 -18 -21 - - - - - - - - -0 -200 -400 -600 -bodywt -awake - -Animals - - - - - - - - - - - - - - - - -Cow -Goat -Dog -Domestic cat -Lion -Donkey -Baboon -Human - - - - - - - -Artiodactyla - - - - - - - - - -Carnivora - - - - - - - - - -Perissodactyla - - - - - - - - - -Primates - - -bottom-toptitle - - diff --git a/tests/testthat/_snaps/guide_legend_group/right-bottomtitle.svg b/tests/testthat/_snaps/guide_legend_group/right-bottomtitle.svg deleted file mode 100644 index c5d71b6..0000000 --- a/tests/testthat/_snaps/guide_legend_group/right-bottomtitle.svg +++ /dev/null @@ -1,127 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -12 -15 -18 -21 - - - - - - - - -0 -200 -400 -600 -bodywt -awake - -Animals - - - - - - - - - - - - - - - - -Cow -Goat -Dog -Domestic cat -Lion -Donkey -Baboon -Human - - - - - - - -Artiodactyla - - - - - - - - - -Carnivora - - - - - - - - - -Perissodactyla - - - - - - - - - -Primates - - -right-bottomtitle - - diff --git a/tests/testthat/_snaps/guide_legend_group/right-lefttitle.svg b/tests/testthat/_snaps/guide_legend_group/right-lefttitle.svg deleted file mode 100644 index 792a3b8..0000000 --- a/tests/testthat/_snaps/guide_legend_group/right-lefttitle.svg +++ /dev/null @@ -1,127 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -12 -15 -18 -21 - - - - - - - - -0 -200 -400 -600 -bodywt -awake - -Animals - - - - - - - - - - - - - - - - -Cow -Goat -Dog -Domestic cat -Lion -Donkey -Baboon -Human - - - - - - - -Artiodactyla - - - - - - - - - -Carnivora - - - - - - - - - -Perissodactyla - - - - - - - - - -Primates - - -right-lefttitle - - diff --git a/tests/testthat/_snaps/guide_legend_group/right-righttitle.svg b/tests/testthat/_snaps/guide_legend_group/right-righttitle.svg deleted file mode 100644 index 1d88a0a..0000000 --- a/tests/testthat/_snaps/guide_legend_group/right-righttitle.svg +++ /dev/null @@ -1,127 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -12 -15 -18 -21 - - - - - - - - -0 -200 -400 -600 -bodywt -awake - -Animals - - - - - - - - - - - - - - - - -Cow -Goat -Dog -Domestic cat -Lion -Donkey -Baboon -Human - - - - - - - -Artiodactyla - - - - - - - - - -Carnivora - - - - - - - - - -Perissodactyla - - - - - - - - - -Primates - - -right-righttitle - - diff --git a/tests/testthat/_snaps/guide_legend_group/right-toptitle.svg b/tests/testthat/_snaps/guide_legend_group/right-toptitle.svg deleted file mode 100644 index 0511048..0000000 --- a/tests/testthat/_snaps/guide_legend_group/right-toptitle.svg +++ /dev/null @@ -1,127 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -12 -15 -18 -21 - - - - - - - - -0 -200 -400 -600 -bodywt -awake - -Animals - - - - - - - - - - - - - - - - -Cow -Goat -Dog -Domestic cat -Lion -Donkey -Baboon -Human - - - - - - - -Artiodactyla - - - - - - - - - -Carnivora - - - - - - - - - -Perissodactyla - - - - - - - - - -Primates - - -right-toptitle - - diff --git a/tests/testthat/test-guide_legend_group.R b/tests/testthat/test-guide_legend_group.R deleted file mode 100644 index b909411..0000000 --- a/tests/testthat/test-guide_legend_group.R +++ /dev/null @@ -1,86 +0,0 @@ -test_that("guide_legend_group works in both direction with all subtitles", { - - df <- msleep[c(9, 28, 11, 5, 34, 54, 24, 53), ] - - base <- ggplot(df, aes(bodywt, awake)) + - geom_point(aes(colour = paste0(order, ".", name))) + - scale_colour_discrete( - name = "Animals", - guide = guide_legend_group(ncol = 2) - ) + - theme_test() + - theme( - legend.key = element_rect(colour = NA, fill = "grey90"), - legend.title.position = "top" - ) - - vdiffr::expect_doppelganger( - "right-toptitle", - base + theme( - legend.position = "right", - gguidance.legend.subtitle.position = "top" - ) - ) - - vdiffr::expect_doppelganger( - "right-lefttitle", - base + theme( - legend.position = "right", - gguidance.legend.subtitle.position = "left" - ) - ) - - vdiffr::expect_doppelganger( - "right-righttitle", - base + theme( - legend.position = "right", - gguidance.legend.subtitle.position = "right" - ) - ) - - vdiffr::expect_doppelganger( - "right-bottomtitle", - base + theme( - legend.position = "right", - gguidance.legend.subtitle.position = "bottom" - ) - ) - - vdiffr::expect_doppelganger( - "bottom-toptitle", - base + theme( - legend.position = "bottom", - gguidance.legend.subtitle.position = "top" - ) - ) - - vdiffr::expect_doppelganger( - "bottom-lefttitle", - base + theme( - legend.position = "bottom", - gguidance.legend.subtitle.position = "left", - gguidance.legend.subtitle = element_text(angle = 90, hjust = 1) - ) - ) - - vdiffr::expect_doppelganger( - "bottom-righttitle", - base + theme( - legend.position = "bottom", - gguidance.legend.subtitle.position = "right", - gguidance.legend.subtitle = element_text(angle = 270) - ) - ) - - vdiffr::expect_doppelganger( - "bottom-bottomtitle", - base + theme( - legend.position = "bottom", - gguidance.legend.subtitle.position = "bottom" - ) - ) - - - - -}) diff --git a/tests/testthat/test-key-group.R b/tests/testthat/test-key-group.R deleted file mode 100644 index c41ed28..0000000 --- a/tests/testthat/test-key-group.R +++ /dev/null @@ -1,64 +0,0 @@ - - -test_that("key_group_auto works as intended", { - - levels <- c("Soda", "Water", "Coffee", "Tea") - groups <- rep(c("Cold drinks", "Hot drinks"), each = 2) - compound <- paste(groups, levels, sep = "-") - - sc <- scale_color_discrete() - sc$train(compound) - - key <- key_group_auto(sep = "-") - test <- key(sc, "colour") - - expect_equal(test$.label, levels) - expect_equal(test$.group, factor(groups)) - - key <- key_group_auto(sep = "-", reverse = TRUE) - test <- key(sc, "colour") - - expect_equal(test$.group, factor(levels, levels)) - expect_equal(test$.label, groups) - -}) - -test_that("key_group_auto rejects expressions", { - - sc <- scale_color_discrete(labels = expression(A^2, 10^B)) - sc$train(c("A", "B")) - - key <- key_group_auto() - expect_error( - key(sc, "colour"), - "Cannot split" - ) -}) - -test_that("key_group_lut works as intended", { - - levels <- c("Coffee", "Tea", "Soda", "Water") - groups <- rep(c("Hot drinks", "Cold drinks"), each = 2) - - sc <- scale_colour_discrete() - sc$train(levels) - sc$train("Car") - - key <- key_group_lut(levels, groups) - test <- key(sc, "colour") - - expect_equal(test$.label, c(levels, "Car")) - expect_equal(test$.group, factor(c(groups, "Other"), unique(c(groups, "Other")))) - -}) - -test_that("key_group_lut cannot deal with mismatching luts", { - - levels <- c("A", "B") - groups <- c("X", "X", "Y") - - expect_error( - key_group_lut(levels, groups), - "must have the same length" - ) -})