From 6d14415df326a545da4de6140f8433c679eac4fb Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Fri, 13 Sep 2024 16:35:21 +0800 Subject: [PATCH] fix wrong guides for null unit key size (#390) --- NAMESPACE | 1 + NEWS.md | 1 + R/guides.R | 59 ++-- R/plot_patchwork.R | 9 +- ...des-with-multiple-plots-with-null-unit.svg | 287 ++++++++++++++++++ .../collect/collect-guides-with-null-unit.svg | 202 ++++++++++++ .../_snaps/collect/collect-normal-guides.svg | 202 ++++++++++++ ...corrected-spacing-for-long-axis-labels.svg | 0 ...oesn-t-interfere-with-title-collection.svg | 0 .../multi-cell-title-and-axis-collection.svg | 0 .../{test-collect_axes.R => test-collect.R} | 29 +- 11 files changed, 758 insertions(+), 32 deletions(-) create mode 100644 tests/testthat/_snaps/collect/collect-guides-with-multiple-plots-with-null-unit.svg create mode 100644 tests/testthat/_snaps/collect/collect-guides-with-null-unit.svg create mode 100644 tests/testthat/_snaps/collect/collect-normal-guides.svg rename tests/testthat/_snaps/{collect_axes => collect}/corrected-spacing-for-long-axis-labels.svg (100%) rename tests/testthat/_snaps/{collect_axes => collect}/empty-areas-doesn-t-interfere-with-title-collection.svg (100%) rename tests/testthat/_snaps/{collect_axes => collect}/multi-cell-title-and-axis-collection.svg (100%) rename tests/testthat/{test-collect_axes.R => test-collect.R} (63%) diff --git a/NAMESPACE b/NAMESPACE index 746d67f..1fc6a09 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -160,6 +160,7 @@ importFrom(gtable,is.gtable) importFrom(stats,ave) importFrom(stats,na.omit) importFrom(utils,as.roman) +importFrom(utils,getFromNamespace) importFrom(utils,modifyList) importFrom(utils,str) importFrom(utils,tail) diff --git a/NEWS.md b/NEWS.md index 0052271..5516f2c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -22,6 +22,7 @@ * Guide and axis merging is slightly more robust when it comes to merging if different graphical parameters that means the same are used (e.g. "black" and "#000000") (#369) +* fix a bug when collecting guides with null unit key size (#390) * Added `nest()` to explicitly nest a patchwork on the LHS of an operator # patchwork 1.2.0 diff --git a/R/guides.R b/R/guides.R index ec16016..40794ac 100644 --- a/R/guides.R +++ b/R/guides.R @@ -59,13 +59,13 @@ collapse_guides <- function(guides) { } guides } + #' @importFrom gtable gtable_width gtable_height gtable gtable_add_grob #' @importFrom grid editGrob heightDetails widthDetails valid.just unit.c unit #' @importFrom ggplot2 margin element_grob element_blank calc_element element_render guides_build <- function(guides, theme) { - theme$legend.spacing <- calc_element("legend.spacing", theme) %||% unit(0.5, "lines") - legend.spacing.y <- calc_element("legend.spacing.y", theme) - legend.spacing.x <- calc_element("legend.spacing.x", theme) + legend.spacing.y <- calc_element(theme, "legend.spacing.y") + legend.spacing.x <- calc_element(theme, "legend.spacing.x") legend.box.margin <- calc_element("legend.box.margin", theme) %||% margin() widths <- exec(unit.c, !!!lapply(guides, gtable_width)) @@ -116,14 +116,9 @@ guides_build <- function(guides, theme) { z = -Inf, clip = "off", name = "legend.box.background" ) } -complete_guide_theme <- function(theme) { - position <- theme$legend.position %||% "right" - if (length(position) == 2) { - warning("Manual legend position not possible for collected guides. Defaulting to 'right'", call. = FALSE) - position <- "right" - } - theme$legend.position <- position - if (position %in% c("top", "bottom")) { +#' @importFrom ggplot2 calc_element +complete_guide_theme <- function(guide_pos, theme) { + if (guide_pos %in% c("top", "bottom")) { theme$legend.box <- theme$legend.box %||% "horizontal" theme$legend.direction <- theme$legend.direction %||% "horizontal" theme$legend.box.just <- theme$legend.box.just %||% c("center", "top") @@ -134,9 +129,26 @@ complete_guide_theme <- function(theme) { } theme } -#' @importFrom grid valid.just -assemble_guides <- function(guides, theme) { - theme <- complete_guide_theme(theme) +#' @importFrom utils getFromNamespace +#' @importFrom ggplot2 calc_element +assemble_guides <- function(guides, position, theme) { + # https://github.com/tidyverse/ggplot2/blob/57ba97fa04dadc6fd73db1904e39a09d57a4fcbe/R/guides-.R#L512 + theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") + theme$legend.spacing.y <- calc_element("legend.spacing.y", theme) + theme$legend.spacing.x <- calc_element("legend.spacing.x", theme) + + # for every position, collect all individual guides and arrange them + # into a guide box which will be inserted into the main gtable + package_box <- try_fetch( + .subset2(getFromNamespace("Guides", "ggplot2"), "package_box"), + error = function(cnd) package_box + ) + package_box(guides, position, theme) +} + +#' @importFrom grid valid.just editGrob +package_box <- function(guides, guide_pos, theme) { + theme <- complete_guide_theme(guide_pos, theme) guides <- guides_build(guides, theme) # Set the justification of the legend box @@ -144,18 +156,21 @@ assemble_guides <- function(guides, theme) { just <- valid.just(calc_element("legend.justification", theme)) xjust <- just[1] yjust <- just[2] - guides <- grid::editGrob(guides, vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust))) + guides <- editGrob(guides, + vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust)) + ) guides <- gtable_add_rows(guides, unit(yjust, 'null')) guides <- gtable_add_rows(guides, unit(1 - yjust, 'null'), 0) guides <- gtable_add_cols(guides, unit(xjust, 'null'), 0) guides <- gtable_add_cols(guides, unit(1 - xjust, 'null')) - guides } + +#' @importFrom ggplot2 calc_element find_panel #' @importFrom gtable gtable_width gtable_height #' @importFrom grid unit.c -attach_guides <- function(table, guides, theme) { - guide_areas <- grepl('panel-guide_area', table$layout$name) +attach_guides <- function(table, guides, position, theme) { + guide_areas <- grepl("panel-guide_area", table$layout$name) if (any(guide_areas)) { area_ind <- which(guide_areas) if (length(area_ind) != 1) { @@ -165,14 +180,8 @@ attach_guides <- function(table, guides, theme) { return(table) } p_loc <- find_panel(table) - position <- theme$legend.position %||% "right" - if (length(position) == 2) { - warning('Manual position of collected guides not supported', call. = FALSE) - position <- "right" - } - spacing <- calc_element("legend.box.spacing", theme) %||% unit(0.2, 'cm') - legend_width <- gtable_width(guides) + legend_width <- gtable_width(guides) legend_height <- gtable_height(guides) if (position == "left") { table <- gtable_add_grob(table, guides, clip = "off", t = p_loc$t, diff --git a/R/plot_patchwork.R b/R/plot_patchwork.R index b6c5eba..b0d3d4e 100644 --- a/R/plot_patchwork.R +++ b/R/plot_patchwork.R @@ -222,8 +222,13 @@ build_patchwork <- function(x, guides = 'auto') { if (!attr(theme, 'complete')) { theme <- theme_get() + theme } - guide_grobs <- assemble_guides(guide_grobs, theme) - gt_new <- attach_guides(gt_new, guide_grobs, theme) + position <- theme$legend.position %||% "right" + if (length(position) == 2) { + warning("Manual legend position not possible for collected guides. Defaulting to 'right'", call. = FALSE) + position <- "right" + } + guide_grobs <- assemble_guides(guide_grobs, position, theme) + gt_new <- attach_guides(gt_new, guide_grobs, position, theme) } } else { gt_new$collected_guides <- guide_grobs diff --git a/tests/testthat/_snaps/collect/collect-guides-with-multiple-plots-with-null-unit.svg b/tests/testthat/_snaps/collect/collect-guides-with-multiple-plots-with-null-unit.svg new file mode 100644 index 0000000..8467e51 --- /dev/null +++ b/tests/testthat/_snaps/collect/collect-guides-with-multiple-plots-with-null-unit.svg @@ -0,0 +1,287 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +100 +200 +300 +400 + + + + + + + + + + +10 +15 +20 +25 +30 +35 +mpg +disp +Plot 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2 +3 +4 +5 + + + + + + + +100 +200 +300 +hp +wt +Plot 3 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2 +3 +4 +5 + + + + + + + +100 +200 +300 +hp +wt +Plot 3 + +mpg + + + + + + + + + +15 +20 +25 +30 + +another + + + + + + + + + +15 +20 +25 +30 +collect guides with multiple plots with null unit + + diff --git a/tests/testthat/_snaps/collect/collect-guides-with-null-unit.svg b/tests/testthat/_snaps/collect/collect-guides-with-null-unit.svg new file mode 100644 index 0000000..27d36ec --- /dev/null +++ b/tests/testthat/_snaps/collect/collect-guides-with-null-unit.svg @@ -0,0 +1,202 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +100 +200 +300 +400 + + + + + + + + + + +10 +15 +20 +25 +30 +35 +mpg +disp +Plot 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2 +3 +4 +5 + + + + + + + +100 +200 +300 +hp +wt +Plot 3 + +mpg + + + + + + + + + +15 +20 +25 +30 +collect guides with null unit + + diff --git a/tests/testthat/_snaps/collect/collect-normal-guides.svg b/tests/testthat/_snaps/collect/collect-normal-guides.svg new file mode 100644 index 0000000..7be4970 --- /dev/null +++ b/tests/testthat/_snaps/collect/collect-normal-guides.svg @@ -0,0 +1,202 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +100 +200 +300 +400 + + + + + + + + + + +10 +15 +20 +25 +30 +35 +mpg +disp +Plot 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2 +3 +4 +5 + + + + + + + +100 +200 +300 +hp +wt +Plot 3 + +mpg + + + + + + + + + +15 +20 +25 +30 +collect normal guides + + diff --git a/tests/testthat/_snaps/collect_axes/corrected-spacing-for-long-axis-labels.svg b/tests/testthat/_snaps/collect/corrected-spacing-for-long-axis-labels.svg similarity index 100% rename from tests/testthat/_snaps/collect_axes/corrected-spacing-for-long-axis-labels.svg rename to tests/testthat/_snaps/collect/corrected-spacing-for-long-axis-labels.svg diff --git a/tests/testthat/_snaps/collect_axes/empty-areas-doesn-t-interfere-with-title-collection.svg b/tests/testthat/_snaps/collect/empty-areas-doesn-t-interfere-with-title-collection.svg similarity index 100% rename from tests/testthat/_snaps/collect_axes/empty-areas-doesn-t-interfere-with-title-collection.svg rename to tests/testthat/_snaps/collect/empty-areas-doesn-t-interfere-with-title-collection.svg diff --git a/tests/testthat/_snaps/collect_axes/multi-cell-title-and-axis-collection.svg b/tests/testthat/_snaps/collect/multi-cell-title-and-axis-collection.svg similarity index 100% rename from tests/testthat/_snaps/collect_axes/multi-cell-title-and-axis-collection.svg rename to tests/testthat/_snaps/collect/multi-cell-title-and-axis-collection.svg diff --git a/tests/testthat/test-collect_axes.R b/tests/testthat/test-collect.R similarity index 63% rename from tests/testthat/test-collect_axes.R rename to tests/testthat/test-collect.R index efc93af..c4bb5ea 100644 --- a/tests/testthat/test-collect_axes.R +++ b/tests/testthat/test-collect.R @@ -1,5 +1,5 @@ test_that("axes and titles are collected correctly for multi-cell plots", { - plots <- wrap_plots(rep(list(p1), 8)) + plots <- wrap_plots(rep(list(p1), 8)) layout <- plot_layout( design = "12345\n62378", axes = "collect", @@ -15,7 +15,6 @@ test_that("axes and titles are collected correctly for multi-cell plots", { }) test_that("axis columns are properly resized", { - p5 <- p1 + scale_y_continuous( labels = function(x) paste0("a long axis label signifying ", x) ) @@ -40,8 +39,28 @@ test_that("axis titles are collected across empty areas", { axis_titles = "collect", design = "#AB\nC#D\nEF#" ) - expect_doppelganger( - "Empty areas doesn't interfere with title collection", - plots + expect_doppelganger( + "Empty areas doesn't interfere with title collection", + plots + ) +}) + +test_that("collect guides works well", { + expect_doppelganger( + "collect normal guides", + wrap_plots(p1 + p3, guides = "collect") + ) + p_guides <- p3 + scale_color_continuous(guide = guide_colorbar( + theme = theme(legend.key.height = unit(1, "null")) + )) + expect_doppelganger( + "collect guides with null unit", + wrap_plots(p1 + p_guides, guides = "collect") + ) + expect_doppelganger( + "collect guides with multiple plots with null unit", + wrap_plots(p1 + p_guides + p_guides + labs(color = "another"), + guides = "collect" ) + ) })