From 0a69e9f7b0b3fad85fef3491065588a16a79c1c6 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Fri, 29 Nov 2024 00:25:03 +0800 Subject: [PATCH 01/26] multiple inside guide box with different position --- R/guide-colorbar.R | 28 +++++++++++++------------ R/guide-legend.R | 44 ++++++++++++++++++++++++++------------- R/guides-.R | 52 +++++++++++++++++++++++++++++++++------------- R/plot-build.R | 14 +++++++------ 4 files changed, 90 insertions(+), 48 deletions(-) diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index c7c424c2ac..bf8b83157a 100644 --- a/R/guide-colorbar.R +++ b/R/guide-colorbar.R @@ -212,19 +212,21 @@ GuideColourbar <- ggproto( hashables = exprs(title, key$.label, decor, name), elements = list( - background = "legend.background", - margin = "legend.margin", - key = "legend.key", - key_height = "legend.key.height", - key_width = "legend.key.width", - text = "legend.text", - theme.title = "legend.title", - text_position = "legend.text.position", - title_position = "legend.title.position", - axis_line = "legend.axis.line", - ticks = "legend.ticks", - ticks_length = "legend.ticks.length", - frame = "legend.frame" + background = "legend.background", + margin = "legend.margin", + key = "legend.key", + key_height = "legend.key.height", + key_width = "legend.key.width", + text = "legend.text", + theme.title = "legend.title", + text_position = "legend.text.position", + title_position = "legend.title.position", + axis_line = "legend.axis.line", + ticks = "legend.ticks", + ticks_length = "legend.ticks.length", + frame = "legend.frame", + inside_position = "legend.position.inside", + inside_justification = "legend.justification.inside" ), extract_key = function(scale, aesthetic, ...) { diff --git a/R/guide-legend.R b/R/guide-legend.R index 37aad2e3f0..291cc98b19 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -169,18 +169,20 @@ GuideLegend <- ggproto( hashables = exprs(title, key$.label, name), elements = list( - background = "legend.background", - margin = "legend.margin", - key = "legend.key", - key_height = "legend.key.height", - key_width = "legend.key.width", - text = "legend.text", - theme.title = "legend.title", - spacing_x = "legend.key.spacing.x", - spacing_y = "legend.key.spacing.y", - text_position = "legend.text.position", - title_position = "legend.title.position", - byrow = "legend.byrow" + background = "legend.background", + margin = "legend.margin", + key = "legend.key", + key_height = "legend.key.height", + key_width = "legend.key.width", + text = "legend.text", + theme.title = "legend.title", + spacing_x = "legend.key.spacing.x", + spacing_y = "legend.key.spacing.y", + text_position = "legend.text.position", + title_position = "legend.title.position", + byrow = "legend.byrow", + inside_position = "legend.position.inside", + inside_justification = "legend.justification.inside" ), extract_params = function(scale, params, @@ -342,7 +344,14 @@ GuideLegend <- ggproto( ) ) elements$text <- calc_element("legend.text", add_theme(theme, text)) - Guide$setup_elements(params, elements, theme) + ans <- Guide$setup_elements(params, elements, theme) + ans$inside_justification <- .subset2( + theme, "legend.justification.inside" + ) %||% .subset2(ans, "inside_position") + ans$inside_justification <- valid.just(.subset2( + ans, "inside_justification" + )) + ans }, override_elements = function(params, elements, theme) { @@ -559,7 +568,14 @@ GuideLegend <- ggproto( gt <- gtable_add_grob( gt, elements$background, name = "background", clip = "off", - t = 1, r = -1, b = -1, l =1, z = -Inf + t = 1, r = -1, b = -1, l = 1, z = -Inf + ) + } + # attach the `position` and `justification` for the inside legends + if (identical(.subset2(params, "position"), "inside")) { + attr(gt, "inside_position") <- .subset2(elements, "inside_position") + attr(gt, "inside_justification") <- .subset2( + elements, "inside_justification" ) } gt diff --git a/R/guides-.R b/R/guides-.R index d250c78025..5c4e38e39a 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -517,9 +517,8 @@ Guides <- ggproto( positions <- vapply( params, function(p) p$position[1] %||% default_position, - character(1) + character(1), USE.NAMES = FALSE ) - positions <- factor(positions, levels = c(.trbl, "inside")) directions <- rep(direction %||% "vertical", length(positions)) if (is.null(direction)) { @@ -529,11 +528,26 @@ Guides <- ggproto( grobs <- vector("list", length(guides)) for (i in seq_along(grobs)) { grobs[[i]] <- guides[[i]]$draw( - theme = theme, position = as.character(positions[i]), + theme = theme, position = positions[i], direction = directions[i], params = params[[i]] ) + if (identical(positions[i], "inside")) { + positions[i] <- paste( + "inside", + paste(attr(.subset2(grobs, i), "inside_position"), collapse = "_"), + paste(attr(.subset2(grobs, i), "inside_justification"), + collapse = "_" + ), + sep = "_" + ) + } } - keep <- !vapply(grobs, is.zero, logical(1)) + + # move inside legends to the last + positions <- factor(positions, + levels = c(.trbl, unique(positions[startsWith(positions, "inside")])) + ) + keep <- !vapply(grobs, is.zero, logical(1), USE.NAMES = FALSE) split(grobs[keep], positions[keep]) }, @@ -546,8 +560,10 @@ Guides <- ggproto( # Determine default direction direction <- switch( position, - inside = , left = , right = "vertical", - top = , bottom = "horizontal" + left = , right = "vertical", + top = , bottom = "horizontal", + # for all inside guide legends + "vertical" ) # Populate missing theme arguments @@ -569,16 +585,22 @@ Guides <- ggproto( # Global justification of the complete legend box global_just <- paste0("legend.justification.", position) global_just <- valid.just(calc_element(global_just, theme)) - - if (position == "inside") { + if (startsWith(position, "inside")) { # The position of inside legends are set by their justification - inside_position <- theme$legend.position.inside %||% global_just - global_xjust <- inside_position[1] - global_yjust <- inside_position[2] - global_margin <- margin() - } else { + global_just <- attr(.subset2(grobs, 1L), "inside_justification") %||% + # fallback to original method of ggplot2 <=3.3.5 + global_just + inside_position <- attr(.subset2(grobs, 1L), "inside_position") %||% + # fallback to original method of ggplot2 <=3.3.5 + .subset2(theme, "legend.position.inside") %||% global_just global_xjust <- global_just[1] global_yjust <- global_just[2] + x <- inside_position[1] + y <- inside_position[2] + global_margin <- margin() + } else { + x <- global_xjust <- global_just[1] + y <- global_yjust <- global_just[2] # Legends to the side of the plot need a margin for justification # relative to the plot panel global_margin <- margin( @@ -620,7 +642,7 @@ Guides <- ggproto( # Set global justification vp <- viewport( - x = global_xjust, y = global_yjust, just = global_just, + x = x, y = y, just = global_just, height = max(heights), width = vp_width ) @@ -658,7 +680,7 @@ Guides <- ggproto( # Set global justification vp <- viewport( - x = global_xjust, y = global_yjust, just = global_just, + x = x, y = y, just = global_just, height = vp_height, width = max(widths) ) diff --git a/R/plot-build.R b/R/plot-build.R index 873f79a32c..3d108f0342 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -515,12 +515,14 @@ table_add_legends <- function(table, legends, theme) { # Add manual legend place <- find_panel(table) - table <- gtable_add_grob( - table, legends$inside, clip = "off", - t = place$t, b = place$b, l = place$l, r = place$r, - name = "guide-box-inside" - ) - + inside_legends <- .subset(legends, startsWith(names(legends), "inside")) + for (i in seq_along(inside_legends)) { + table <- gtable_add_grob( + table, .subset2(inside_legends, i), clip = "off", + t = place$t, b = place$b, l = place$l, r = place$r, + name = paste("guide-box-inside", i, sep = "-") + ) + } table } From 790fb2ef57fc61580d14fb02b7a1c2434e8ea8b8 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Fri, 29 Nov 2024 19:05:22 +0800 Subject: [PATCH 02/26] merge guide legends depend on `legend.position.inside` only --- R/guide-colorbar.R | 3 +-- R/guide-legend.R | 20 ++++++-------------- R/guides-.R | 14 +++++++------- 3 files changed, 14 insertions(+), 23 deletions(-) diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index bf8b83157a..17eae0ddf6 100644 --- a/R/guide-colorbar.R +++ b/R/guide-colorbar.R @@ -225,8 +225,7 @@ GuideColourbar <- ggproto( ticks = "legend.ticks", ticks_length = "legend.ticks.length", frame = "legend.frame", - inside_position = "legend.position.inside", - inside_justification = "legend.justification.inside" + inside_position = "legend.position.inside" ), extract_key = function(scale, aesthetic, ...) { diff --git a/R/guide-legend.R b/R/guide-legend.R index 291cc98b19..34f5f72abb 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -181,8 +181,7 @@ GuideLegend <- ggproto( text_position = "legend.text.position", title_position = "legend.title.position", byrow = "legend.byrow", - inside_position = "legend.position.inside", - inside_justification = "legend.justification.inside" + inside_position = "legend.position.inside" ), extract_params = function(scale, params, @@ -344,14 +343,7 @@ GuideLegend <- ggproto( ) ) elements$text <- calc_element("legend.text", add_theme(theme, text)) - ans <- Guide$setup_elements(params, elements, theme) - ans$inside_justification <- .subset2( - theme, "legend.justification.inside" - ) %||% .subset2(ans, "inside_position") - ans$inside_justification <- valid.just(.subset2( - ans, "inside_justification" - )) - ans + Guide$setup_elements(params, elements, theme) }, override_elements = function(params, elements, theme) { @@ -571,12 +563,12 @@ GuideLegend <- ggproto( t = 1, r = -1, b = -1, l = 1, z = -Inf ) } - # attach the `position` and `justification` for the inside legends + + # for inside guide legends, we also save the position values + # in this way, we can identify legends with same position + # and then merge them into same guide box in `Guides$draw()` if (identical(.subset2(params, "position"), "inside")) { attr(gt, "inside_position") <- .subset2(elements, "inside_position") - attr(gt, "inside_justification") <- .subset2( - elements, "inside_justification" - ) } gt } diff --git a/R/guides-.R b/R/guides-.R index 5c4e38e39a..913287d7bf 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -531,13 +531,12 @@ Guides <- ggproto( theme = theme, position = positions[i], direction = directions[i], params = params[[i]] ) + # we'll merge inside legends with same coordinate into same guide box + # here, we define the groups of the inside legends if (identical(positions[i], "inside")) { positions[i] <- paste( "inside", paste(attr(.subset2(grobs, i), "inside_position"), collapse = "_"), - paste(attr(.subset2(grobs, i), "inside_justification"), - collapse = "_" - ), sep = "_" ) } @@ -548,6 +547,9 @@ Guides <- ggproto( levels = c(.trbl, unique(positions[startsWith(positions, "inside")])) ) keep <- !vapply(grobs, is.zero, logical(1), USE.NAMES = FALSE) + + # we grouped the legends by the positions + # for inside legends, they'll be splitted by the actual inside coordinate split(grobs[keep], positions[keep]) }, @@ -586,10 +588,8 @@ Guides <- ggproto( global_just <- paste0("legend.justification.", position) global_just <- valid.just(calc_element(global_just, theme)) if (startsWith(position, "inside")) { - # The position of inside legends are set by their justification - global_just <- attr(.subset2(grobs, 1L), "inside_justification") %||% - # fallback to original method of ggplot2 <=3.3.5 - global_just + # for inside guide legends, the position was attached in + # each grob of the input grobs (which should share the same position) inside_position <- attr(.subset2(grobs, 1L), "inside_position") %||% # fallback to original method of ggplot2 <=3.3.5 .subset2(theme, "legend.position.inside") %||% global_just From 7e156d00c96f898b7a29b3e4538f280e5d9a824f Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Fri, 29 Nov 2024 19:29:19 +0800 Subject: [PATCH 03/26] fix inside legend justification --- R/guides-.R | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index 913287d7bf..8c4cc69553 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -584,14 +584,15 @@ Guides <- ggproto( stretch_x <- any(unlist(lapply(widths, unitType)) == "null") stretch_y <- any(unlist(lapply(heights, unitType)) == "null") - # Global justification of the complete legend box - global_just <- paste0("legend.justification.", position) - global_just <- valid.just(calc_element(global_just, theme)) if (startsWith(position, "inside")) { + # Global justification of the complete legend box + global_just <- valid.just(calc_element( + "legend.justification.inside", theme + )) # for inside guide legends, the position was attached in # each grob of the input grobs (which should share the same position) inside_position <- attr(.subset2(grobs, 1L), "inside_position") %||% - # fallback to original method of ggplot2 <=3.3.5 + # fallback to original method of ggplot2 <=3.5.1 .subset2(theme, "legend.position.inside") %||% global_just global_xjust <- global_just[1] global_yjust <- global_just[2] @@ -599,6 +600,9 @@ Guides <- ggproto( y <- inside_position[2] global_margin <- margin() } else { + # Global justification of the complete legend box + global_just <- paste0("legend.justification.", position) + global_just <- valid.just(calc_element(global_just, theme)) x <- global_xjust <- global_just[1] y <- global_yjust <- global_just[2] # Legends to the side of the plot need a margin for justification From 1d7c5b93419a3c70001657cea6703112ede9f617 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Fri, 29 Nov 2024 19:48:42 +0800 Subject: [PATCH 04/26] no inside guide box if no inside guide legends --- tests/testthat/test-guides.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index 5904676541..c326566b82 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -159,7 +159,7 @@ test_that("empty guides are dropped", { guides <- p$plot$guides$draw(theme_gray(), direction = "vertical") # All guide-boxes should be empty - expect_equal(lengths(guides, use.names = FALSE), rep(0, 5)) + expect_equal(lengths(guides, use.names = FALSE), rep(0, 4)) }) test_that("bins can be parsed by guides for all scale types", { From c6e90eafc39cf506dfd456b9ffc5e32eb30bc031 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Fri, 29 Nov 2024 19:54:03 +0800 Subject: [PATCH 05/26] add `guide-box-index` when there is no inside legends --- R/plot-build.R | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index 3d108f0342..04c1fcd721 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -516,11 +516,19 @@ table_add_legends <- function(table, legends, theme) { # Add manual legend place <- find_panel(table) inside_legends <- .subset(legends, startsWith(names(legends), "inside")) - for (i in seq_along(inside_legends)) { + if (length(inside_legends)) { + for (i in seq_along(inside_legends)) { + table <- gtable_add_grob( + table, .subset2(inside_legends, i), clip = "off", + t = place$t, b = place$b, l = place$l, r = place$r, + name = paste("guide-box-inside", i, sep = "-") + ) + } + } else { # to be consistent with original gtable layout table <- gtable_add_grob( - table, .subset2(inside_legends, i), clip = "off", - t = place$t, b = place$b, l = place$l, r = place$r, - name = paste("guide-box-inside", i, sep = "-") + table, zeroGrob(), clip = "off", + t = 1, b = 1, l = place$l, r = place$r, + name = "guide-box-inside" ) } table From 51889d458e7ceeafa43d12f6bb1a21e6f21f4e7e Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Fri, 29 Nov 2024 19:55:23 +0800 Subject: [PATCH 06/26] fix inside guide box area --- R/plot-build.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/plot-build.R b/R/plot-build.R index 04c1fcd721..83eca708f2 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -527,7 +527,7 @@ table_add_legends <- function(table, legends, theme) { } else { # to be consistent with original gtable layout table <- gtable_add_grob( table, zeroGrob(), clip = "off", - t = 1, b = 1, l = place$l, r = place$r, + t = place$t, b = place$b, l = place$l, r = place$r, name = "guide-box-inside" ) } From b7754c8b452af92c19a5b1468cc98876a2c08532 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Fri, 29 Nov 2024 23:56:13 +0800 Subject: [PATCH 07/26] manage position in `Guides$assemble()` --- R/guide-colorbar.R | 8 ++- R/guide-custom.R | 10 ++++ R/guide-legend.R | 20 +++---- R/guides-.R | 139 ++++++++++++++++++++++++++------------------- R/plot-build.R | 10 ++-- 5 files changed, 113 insertions(+), 74 deletions(-) diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index 17eae0ddf6..771b32281b 100644 --- a/R/guide-colorbar.R +++ b/R/guide-colorbar.R @@ -146,7 +146,13 @@ guide_colourbar <- function( theme <- deprecated_guide_args(theme, ...) if (!is.null(position)) { - position <- arg_match0(position, c(.trbl, "inside")) + if (is.numeric(position)) { + if (length(position) != 2L) { + cli::cli_abort("{.arg position} must be a numeric of length 2") + } + } else { + position <- arg_match0(position, c(.trbl, "inside")) + } } check_number_decimal(alpha, min = 0, max = 1, allow_na = TRUE) diff --git a/R/guide-custom.R b/R/guide-custom.R index f602bfc843..c1e9c0954e 100644 --- a/R/guide-custom.R +++ b/R/guide-custom.R @@ -50,6 +50,16 @@ guide_custom <- function( cli::cli_abort("{.arg height} must be a single {.cls unit}, not a unit vector.") } + if (!is.null(position)) { + if (is.numeric(position)) { + if (length(position) != 2L) { + cli::cli_abort("{.arg position} must be a numeric of length 2") + } + } else { + position <- arg_match0(position, c(.trbl, "inside")) + } + } + new_guide( grob = grob, width = width, diff --git a/R/guide-legend.R b/R/guide-legend.R index 34f5f72abb..7eac047c19 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -17,7 +17,8 @@ #' differently from the plot's theme settings. The `theme` argument in the #' guide overrides, and is combined with, the plot's theme. #' @param position A character string indicating where the legend should be -#' placed relative to the plot panels. +#' placed relative to the plot panels, or a numeric value of length two +#' setting the placement of legends. #' @param direction A character string indicating the direction of the guide. #' One of "horizontal" or "vertical". #' @param override.aes A list specifying aesthetic parameters of legend key. @@ -116,7 +117,13 @@ guide_legend <- function( theme <- deprecated_guide_args(theme, ...) if (!is.null(position)) { - position <- arg_match0(position, c(.trbl, "inside")) + if (is.numeric(position)) { + if (length(position) != 2L) { + cli::cli_abort("{.arg position} must be a numeric of length 2") + } + } else { + position <- arg_match0(position, c(.trbl, "inside")) + } } new_guide( @@ -180,8 +187,7 @@ GuideLegend <- ggproto( spacing_y = "legend.key.spacing.y", text_position = "legend.text.position", title_position = "legend.title.position", - byrow = "legend.byrow", - inside_position = "legend.position.inside" + byrow = "legend.byrow" ), extract_params = function(scale, params, @@ -564,12 +570,6 @@ GuideLegend <- ggproto( ) } - # for inside guide legends, we also save the position values - # in this way, we can identify legends with same position - # and then merge them into same guide box in `Guides$draw()` - if (identical(.subset2(params, "position"), "inside")) { - attr(gt, "inside_position") <- .subset2(elements, "inside_position") - } gt } ) diff --git a/R/guides-.R b/R/guides-.R index 8c4cc69553..b3da36fb85 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -471,7 +471,7 @@ Guides <- ggproto( # for every position, collect all individual guides and arrange them # into a guide box which will be inserted into the main gtable # Combining multiple guides in a guide box - assemble = function(self, theme) { + assemble = function(self, theme, params = self$params, guides = self$guides) { if (length(self$guides) < 1) { return(zeroGrob()) @@ -485,15 +485,61 @@ Guides <- ggproto( return(zeroGrob()) } + # extract the guide position + positions <- vapply( + params, + function(p) p$position[1] %||% default_position, + character(1), USE.NAMES = FALSE + ) + # Populate key sizes theme$legend.key.width <- calc_element("legend.key.width", theme) theme$legend.key.height <- calc_element("legend.key.height", theme) - grobs <- self$draw(theme, default_position, theme$legend.direction) + grobs <- self$draw(theme, positions, theme$legend.direction) + keep <- !vapply(grobs, is.zero, logical(1), USE.NAMES = FALSE) + grobs <- grobs[keep] if (length(grobs) < 1) { return(zeroGrob()) } - grobs <- grobs[order(names(grobs))] + + # prepare the position of inside legends + default_inside_position <- calc_element( + "legend.position.inside", theme + ) %||% valid.just(calc_element("legend.justification.inside", theme)) + inside_positions <- vector("list", length(positions)) + + # we'll merge inside legends with same coordinate into same guide box + # we grouped the legends by the positions, for inside legends, they'll be + # splitted by the actual inside coordinate + groups <- positions + for (i in seq_along(positions)) { + if (identical(positions[i], "inside")) { + # the actual inside position can be set in each guide by `theme` + # argument + inside_positions[[i]] <- calc_element( + "legend.position.inside", params[[i]]$theme + ) %||% default_inside_position + groups[i] <- paste0("inside_", + paste(inside_positions[[i]], collapse = "_") + ) + } + } + positions <- positions[keep] + inside_positions <- inside_positions[keep] + groups <- groups[keep] + + # we group the guide legends + locs <- vec_group_loc(groups) + indices <- locs$loc + grobs <- vec_chop(grobs, indices = indices) + names(grobs) <- locs$key + + # for each group, they share the same locations, + # so we only extract the first one of `positions` and `inside_positions` + first_indice <- lapply(indices, `[[`, 1L) + positions <- vec_chop(positions, indices = first_indice) + inside_positions <- vec_chop(inside_positions, indices = first_indice) # Set spacing theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") @@ -502,27 +548,24 @@ Guides <- ggproto( Map( grobs = grobs, - position = names(grobs), + position = positions, + inside_position = inside_positions, self$package_box, MoreArgs = list(theme = theme) ) }, # Render the guides into grobs - draw = function(self, theme, - default_position = "right", - direction = NULL, + draw = function(self, theme, positions, direction = NULL, params = self$params, guides = self$guides) { - positions <- vapply( - params, - function(p) p$position[1] %||% default_position, - character(1), USE.NAMES = FALSE - ) - - directions <- rep(direction %||% "vertical", length(positions)) if (is.null(direction)) { - directions[positions %in% c("top", "bottom")] <- "horizontal" + directions <- ifelse( + positions %in% c("top", "bottom"), + "horizontal", "vertical" + ) + } else { + directions <- rep(direction, length(positions)) } grobs <- vector("list", length(guides)) @@ -531,30 +574,13 @@ Guides <- ggproto( theme = theme, position = positions[i], direction = directions[i], params = params[[i]] ) - # we'll merge inside legends with same coordinate into same guide box - # here, we define the groups of the inside legends - if (identical(positions[i], "inside")) { - positions[i] <- paste( - "inside", - paste(attr(.subset2(grobs, i), "inside_position"), collapse = "_"), - sep = "_" - ) - } } - - # move inside legends to the last - positions <- factor(positions, - levels = c(.trbl, unique(positions[startsWith(positions, "inside")])) - ) - keep <- !vapply(grobs, is.zero, logical(1), USE.NAMES = FALSE) - - # we grouped the legends by the positions - # for inside legends, they'll be splitted by the actual inside coordinate - split(grobs[keep], positions[keep]) + grobs }, - package_box = function(grobs, position, theme) { - + # here, we put `inside_position` in the last, so that it won't break current + # implement of patchwork + package_box = function(grobs, position, theme, inside_position = NULL) { if (is.zero(grobs) || length(grobs) == 0) { return(zeroGrob()) } @@ -562,10 +588,8 @@ Guides <- ggproto( # Determine default direction direction <- switch( position, - left = , right = "vertical", - top = , bottom = "horizontal", - # for all inside guide legends - "vertical" + inside = , left = , right = "vertical", + top = , bottom = "horizontal" ) # Populate missing theme arguments @@ -584,25 +608,24 @@ Guides <- ggproto( stretch_x <- any(unlist(lapply(widths, unitType)) == "null") stretch_y <- any(unlist(lapply(heights, unitType)) == "null") - if (startsWith(position, "inside")) { - # Global justification of the complete legend box - global_just <- valid.just(calc_element( - "legend.justification.inside", theme - )) - # for inside guide legends, the position was attached in - # each grob of the input grobs (which should share the same position) - inside_position <- attr(.subset2(grobs, 1L), "inside_position") %||% - # fallback to original method of ggplot2 <=3.5.1 - .subset2(theme, "legend.position.inside") %||% global_just - global_xjust <- global_just[1] - global_yjust <- global_just[2] - x <- inside_position[1] - y <- inside_position[2] + # Global justification of the complete legend box + global_just <- paste0("legend.justification.", position) + global_just <- valid.just(calc_element(global_just, theme)) + + if (position == "inside") { + # The position of inside legends are set by their justification + inside_just <- theme$legend.position.inside %||% global_just + global_xjust <- inside_just[1] + global_yjust <- inside_just[2] global_margin <- margin() + if (is.null(inside_position)) { # for backward compatibility + x <- global_xjust + y <- global_yjust + } else { + x <- inside_position[1L] + y <- inside_position[2L] + } } else { - # Global justification of the complete legend box - global_just <- paste0("legend.justification.", position) - global_just <- valid.just(calc_element(global_just, theme)) x <- global_xjust <- global_just[1] y <- global_yjust <- global_just[2] # Legends to the side of the plot need a margin for justification @@ -684,7 +707,7 @@ Guides <- ggproto( # Set global justification vp <- viewport( - x = x, y = y, just = global_just, + x = global_xjust, y = global_yjust, just = global_just, height = vp_height, width = max(widths) ) diff --git a/R/plot-build.R b/R/plot-build.R index 83eca708f2..3425474e34 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -479,7 +479,7 @@ table_add_legends <- function(table, legends, theme) { table <- gtable_add_cols(table, spacing$right, pos = -1) table <- gtable_add_cols(table, widths$right, pos = -1) table <- gtable_add_grob( - table, legends$right, clip = "off", + table, legends$right %||% zeroGrob(), clip = "off", t = place$t, b = place$b, l = -1, r = -1, name = "guide-box-right" ) @@ -488,7 +488,7 @@ table_add_legends <- function(table, legends, theme) { table <- gtable_add_cols(table, spacing$left, pos = 0) table <- gtable_add_cols(table, widths$left, pos = 0) table <- gtable_add_grob( - table, legends$left, clip = "off", + table, legends$left %||% zeroGrob(), clip = "off", t = place$t, b = place$b, l = 1, r = 1, name = "guide-box-left" ) @@ -499,7 +499,7 @@ table_add_legends <- function(table, legends, theme) { table <- gtable_add_rows(table, spacing$bottom, pos = -1) table <- gtable_add_rows(table, heights$bottom, pos = -1) table <- gtable_add_grob( - table, legends$bottom, clip = "off", + table, legends$bottom %||% zeroGrob(), clip = "off", t = -1, b = -1, l = place$l, r = place$r, name = "guide-box-bottom" ) @@ -508,7 +508,7 @@ table_add_legends <- function(table, legends, theme) { table <- gtable_add_rows(table, spacing$top, pos = 0) table <- gtable_add_rows(table, heights$top, pos = 0) table <- gtable_add_grob( - table, legends$top, clip = "off", + table, legends$top %||% zeroGrob(), clip = "off", t = 1, b = 1, l = place$l, r = place$r, name = "guide-box-top" ) @@ -519,7 +519,7 @@ table_add_legends <- function(table, legends, theme) { if (length(inside_legends)) { for (i in seq_along(inside_legends)) { table <- gtable_add_grob( - table, .subset2(inside_legends, i), clip = "off", + table, inside_legends[[i]], clip = "off", t = place$t, b = place$b, l = place$l, r = place$r, name = paste("guide-box-inside", i, sep = "-") ) From d7aa7c48ef5fc26d3c8cba7381c30101824d60f9 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Fri, 29 Nov 2024 23:57:56 +0800 Subject: [PATCH 08/26] revert --- R/guide-legend.R | 36 ++++++++++++++---------------------- 1 file changed, 14 insertions(+), 22 deletions(-) diff --git a/R/guide-legend.R b/R/guide-legend.R index 7eac047c19..d6e0afe7dc 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -17,8 +17,7 @@ #' differently from the plot's theme settings. The `theme` argument in the #' guide overrides, and is combined with, the plot's theme. #' @param position A character string indicating where the legend should be -#' placed relative to the plot panels, or a numeric value of length two -#' setting the placement of legends. +#' placed relative to the plot panels. #' @param direction A character string indicating the direction of the guide. #' One of "horizontal" or "vertical". #' @param override.aes A list specifying aesthetic parameters of legend key. @@ -117,13 +116,7 @@ guide_legend <- function( theme <- deprecated_guide_args(theme, ...) if (!is.null(position)) { - if (is.numeric(position)) { - if (length(position) != 2L) { - cli::cli_abort("{.arg position} must be a numeric of length 2") - } - } else { - position <- arg_match0(position, c(.trbl, "inside")) - } + position <- arg_match0(position, c(.trbl, "inside")) } new_guide( @@ -176,18 +169,18 @@ GuideLegend <- ggproto( hashables = exprs(title, key$.label, name), elements = list( - background = "legend.background", - margin = "legend.margin", - key = "legend.key", - key_height = "legend.key.height", - key_width = "legend.key.width", - text = "legend.text", - theme.title = "legend.title", - spacing_x = "legend.key.spacing.x", - spacing_y = "legend.key.spacing.y", - text_position = "legend.text.position", - title_position = "legend.title.position", - byrow = "legend.byrow" + background = "legend.background", + margin = "legend.margin", + key = "legend.key", + key_height = "legend.key.height", + key_width = "legend.key.width", + text = "legend.text", + theme.title = "legend.title", + spacing_x = "legend.key.spacing.x", + spacing_y = "legend.key.spacing.y", + text_position = "legend.text.position", + title_position = "legend.title.position", + byrow = "legend.byrow" ), extract_params = function(scale, params, @@ -569,7 +562,6 @@ GuideLegend <- ggproto( t = 1, r = -1, b = -1, l = 1, z = -Inf ) } - gt } ) From a4f1221420f20f12798a0093af3bf6a67a6436a3 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Fri, 29 Nov 2024 23:58:22 +0800 Subject: [PATCH 09/26] revert --- R/guide-colorbar.R | 35 ++++++++++++++--------------------- 1 file changed, 14 insertions(+), 21 deletions(-) diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index 771b32281b..c7c424c2ac 100644 --- a/R/guide-colorbar.R +++ b/R/guide-colorbar.R @@ -146,13 +146,7 @@ guide_colourbar <- function( theme <- deprecated_guide_args(theme, ...) if (!is.null(position)) { - if (is.numeric(position)) { - if (length(position) != 2L) { - cli::cli_abort("{.arg position} must be a numeric of length 2") - } - } else { - position <- arg_match0(position, c(.trbl, "inside")) - } + position <- arg_match0(position, c(.trbl, "inside")) } check_number_decimal(alpha, min = 0, max = 1, allow_na = TRUE) @@ -218,20 +212,19 @@ GuideColourbar <- ggproto( hashables = exprs(title, key$.label, decor, name), elements = list( - background = "legend.background", - margin = "legend.margin", - key = "legend.key", - key_height = "legend.key.height", - key_width = "legend.key.width", - text = "legend.text", - theme.title = "legend.title", - text_position = "legend.text.position", - title_position = "legend.title.position", - axis_line = "legend.axis.line", - ticks = "legend.ticks", - ticks_length = "legend.ticks.length", - frame = "legend.frame", - inside_position = "legend.position.inside" + background = "legend.background", + margin = "legend.margin", + key = "legend.key", + key_height = "legend.key.height", + key_width = "legend.key.width", + text = "legend.text", + theme.title = "legend.title", + text_position = "legend.text.position", + title_position = "legend.title.position", + axis_line = "legend.axis.line", + ticks = "legend.ticks", + ticks_length = "legend.ticks.length", + frame = "legend.frame" ), extract_key = function(scale, aesthetic, ...) { From d1f6833d938ae01f2de1391cca877e59ef21746e Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Fri, 29 Nov 2024 23:58:46 +0800 Subject: [PATCH 10/26] revert --- R/guide-custom.R | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/R/guide-custom.R b/R/guide-custom.R index c1e9c0954e..f602bfc843 100644 --- a/R/guide-custom.R +++ b/R/guide-custom.R @@ -50,16 +50,6 @@ guide_custom <- function( cli::cli_abort("{.arg height} must be a single {.cls unit}, not a unit vector.") } - if (!is.null(position)) { - if (is.numeric(position)) { - if (length(position) != 2L) { - cli::cli_abort("{.arg position} must be a numeric of length 2") - } - } else { - position <- arg_match0(position, c(.trbl, "inside")) - } - } - new_guide( grob = grob, width = width, From c4882c69801cb308d65bf54ed3cbeccfd04533ca Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Sat, 30 Nov 2024 00:07:12 +0800 Subject: [PATCH 11/26] fix inside legend coordinates --- R/guides-.R | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index b3da36fb85..0e3cf0127f 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -618,7 +618,10 @@ Guides <- ggproto( global_xjust <- inside_just[1] global_yjust <- inside_just[2] global_margin <- margin() - if (is.null(inside_position)) { # for backward compatibility + # # for backward compatibility, no `inside_position` input + if (is.null(inside_position) || + # `inside_position` is a list of length one + is.null(inside_position <- inside_position[[1L]])) { x <- global_xjust y <- global_yjust } else { @@ -707,7 +710,7 @@ Guides <- ggproto( # Set global justification vp <- viewport( - x = global_xjust, y = global_yjust, just = global_just, + x = x, y = y, just = global_just, height = vp_height, width = max(widths) ) From 9854c586d41e8344de4ab03e06eaffebfc9ffcb9 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Sat, 30 Nov 2024 00:26:09 +0800 Subject: [PATCH 12/26] fix test error --- R/guides-.R | 8 ++++++-- tests/testthat/test-guides.R | 4 ++-- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index 0e3cf0127f..b68c462be2 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -509,7 +509,6 @@ Guides <- ggproto( ) %||% valid.just(calc_element("legend.justification.inside", theme)) inside_positions <- vector("list", length(positions)) - # we'll merge inside legends with same coordinate into same guide box # we grouped the legends by the positions, for inside legends, they'll be # splitted by the actual inside coordinate groups <- positions @@ -556,9 +555,14 @@ Guides <- ggproto( }, # Render the guides into grobs - draw = function(self, theme, positions, direction = NULL, + draw = function(self, theme, positions = NULL, direction = NULL, params = self$params, guides = self$guides) { + positions <- positions %||% vapply( + params, + function(p) p$position[1] %||% "right", + character(1), USE.NAMES = FALSE + ) if (is.null(direction)) { directions <- ifelse( positions %in% c("top", "bottom"), diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index c326566b82..fd3a01c85d 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -156,10 +156,10 @@ test_that("empty guides are dropped", { expect_equal(nrow(gd), 0) # Draw guides - guides <- p$plot$guides$draw(theme_gray(), direction = "vertical") + guides <- p$plot$guides$assemble(theme_gray()) # All guide-boxes should be empty - expect_equal(lengths(guides, use.names = FALSE), rep(0, 4)) + expect_true(is.zero(guides)) }) test_that("bins can be parsed by guides for all scale types", { From 1de623f25bc50ee9ff05579f402f6e27d18daec6 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Sat, 30 Nov 2024 00:31:15 +0800 Subject: [PATCH 13/26] no need to prepare inside legends when empty --- R/plot-build.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index 3425474e34..23db50285b 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -448,8 +448,8 @@ table_add_tag <- function(table, label, theme) { table_add_legends <- function(table, legends, theme) { if (is.zero(legends)) { - legends <- rep(list(zeroGrob()), 5) - names(legends) <- c(.trbl, "inside") + legends <- rep(list(zeroGrob()), 4) + names(legends) <- .trbl } # Extract sizes @@ -515,7 +515,7 @@ table_add_legends <- function(table, legends, theme) { # Add manual legend place <- find_panel(table) - inside_legends <- .subset(legends, startsWith(names(legends), "inside")) + inside_legends <- legends[startsWith(names(legends), "inside")] if (length(inside_legends)) { for (i in seq_along(inside_legends)) { table <- gtable_add_grob( From 2c1a0d1d93bd9b0c1a4338a146a2f1bed8c929cf Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Sat, 30 Nov 2024 01:34:53 +0800 Subject: [PATCH 14/26] allow set the inside justification for each legend --- R/guides-.R | 59 +++++++++++++++++++++++++++++++++++------------------ 1 file changed, 39 insertions(+), 20 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index b68c462be2..2b9f22d70d 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -504,28 +504,37 @@ Guides <- ggproto( } # prepare the position of inside legends + default_inside_just <- valid.just( + calc_element("legend.justification.inside", theme) + ) default_inside_position <- calc_element( "legend.position.inside", theme - ) %||% valid.just(calc_element("legend.justification.inside", theme)) - inside_positions <- vector("list", length(positions)) + ) + inside_justs <- inside_positions <- vector("list", length(positions)) # we grouped the legends by the positions, for inside legends, they'll be # splitted by the actual inside coordinate groups <- positions for (i in seq_along(positions)) { if (identical(positions[i], "inside")) { - # the actual inside position can be set in each guide by `theme` - # argument + # the actual inside position and justification can be set in each guide + # by `theme` argument + inside_justs[[i]] <- valid.just(calc_element( + "legend.justification.inside", params[[i]]$theme + )) %||% default_inside_just inside_positions[[i]] <- calc_element( "legend.position.inside", params[[i]]$theme - ) %||% default_inside_position - groups[i] <- paste0("inside_", - paste(inside_positions[[i]], collapse = "_") + ) %||% default_inside_position %||% inside_justs[[i]] + groups[i] <- paste("inside", + paste(inside_positions[[i]], collapse = "_"), + paste(inside_justs[[i]], collapse = "_"), + sep = "_" ) } } positions <- positions[keep] inside_positions <- inside_positions[keep] + inside_justs <- inside_justs[keep] groups <- groups[keep] # we group the guide legends @@ -539,6 +548,7 @@ Guides <- ggproto( first_indice <- lapply(indices, `[[`, 1L) positions <- vec_chop(positions, indices = first_indice) inside_positions <- vec_chop(inside_positions, indices = first_indice) + inside_justs <- vec_chop(inside_justs, indices = first_indice) # Set spacing theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") @@ -549,6 +559,7 @@ Guides <- ggproto( grobs = grobs, position = positions, inside_position = inside_positions, + inside_just = inside_justs, self$package_box, MoreArgs = list(theme = theme) ) @@ -584,7 +595,8 @@ Guides <- ggproto( # here, we put `inside_position` in the last, so that it won't break current # implement of patchwork - package_box = function(grobs, position, theme, inside_position = NULL) { + package_box = function(grobs, position, theme, + inside_position = NULL, inside_just = NULL) { if (is.zero(grobs) || length(grobs) == 0) { return(zeroGrob()) } @@ -612,17 +624,20 @@ Guides <- ggproto( stretch_x <- any(unlist(lapply(widths, unitType)) == "null") stretch_y <- any(unlist(lapply(heights, unitType)) == "null") - # Global justification of the complete legend box - global_just <- paste0("legend.justification.", position) - global_just <- valid.just(calc_element(global_just, theme)) - if (position == "inside") { - # The position of inside legends are set by their justification - inside_just <- theme$legend.position.inside %||% global_just - global_xjust <- inside_just[1] - global_yjust <- inside_just[2] - global_margin <- margin() - # # for backward compatibility, no `inside_position` input + # for backward compatibility, no `inside_just` input + if (is.null(inside_just) || + # `inside_just` is a list of length one + is.null(inside_just <- inside_just[[1L]])) { + global_just <- valid.just( + calc_element("legend.justification.inside", theme) + ) + } else { + global_just <- inside_just + } + global_xjust <- global_just[1] + global_yjust <- global_just[2] + # for backward compatibility, no `inside_position` input if (is.null(inside_position) || # `inside_position` is a list of length one is.null(inside_position <- inside_position[[1L]])) { @@ -632,9 +647,13 @@ Guides <- ggproto( x <- inside_position[1L] y <- inside_position[2L] } + global_margin <- margin() } else { - x <- global_xjust <- global_just[1] - y <- global_yjust <- global_just[2] + # Global justification of the complete legend box + global_just <- paste0("legend.justification.", position) + global_just <- valid.just(calc_element(global_just, theme)) + x <- global_xjust <- global_just[1] + y <- global_yjust <- global_just[2] # Legends to the side of the plot need a margin for justification # relative to the plot panel global_margin <- margin( From 04827f5db397b6a873517041ee59bfdae307cada Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Sat, 30 Nov 2024 01:35:14 +0800 Subject: [PATCH 15/26] test multiple inside legends with different positions --- tests/testthat/test-guides.R | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index fd3a01c85d..22de6c4a07 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -268,6 +268,25 @@ test_that("guides are positioned correctly", { expect_doppelganger("legend inside plot, bottom left of legend at center", p2 + theme(legend.justification = c(0,0), legend.position.inside = c(0.5,0.5)) ) + expect_doppelganger("legend inside plot, multiple positions", + p2 + + guides( + colour = guide_colourbar( + position = "inside", + theme = theme( + legend.position.inside = c(0, 1), + legend.justification.inside = c(0, 1) + ) + ), + fill = guide_legend( + position = "inside", + theme = theme( + legend.position.inside = c(1, 0), + legend.justification.inside = c(1, 0) + ) + ) + ) + ) }) test_that("guides title and text are positioned correctly", { From 92f57f8e49221c0e4289c3b26ce7ca11896bdfe3 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Sat, 30 Nov 2024 01:57:22 +0800 Subject: [PATCH 16/26] fix R CMD check error --- R/guides-.R | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index 2b9f22d70d..1643e14aba 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -518,13 +518,18 @@ Guides <- ggproto( for (i in seq_along(positions)) { if (identical(positions[i], "inside")) { # the actual inside position and justification can be set in each guide - # by `theme` argument - inside_justs[[i]] <- valid.just(calc_element( - "legend.justification.inside", params[[i]]$theme - )) %||% default_inside_just - inside_positions[[i]] <- calc_element( - "legend.position.inside", params[[i]]$theme - ) %||% default_inside_position %||% inside_justs[[i]] + # by `theme` argument, here, we won't use `calc_element()` which will + # use inherits from `legend.justification` or `legend.position`, we only + # follow the inside elements from the guide theme + inside_just <- params[[i]]$theme[["legend.justification.inside"]] + if (is.null(inside_just)) { + inside_justs[[i]] <- default_inside_just + } else { + inside_justs[[i]] <- valid.just(inside_just) + } + inside_positions[[i]] <- params[[i]]$theme[[ + "legend.position.inside" + ]] %||% default_inside_position %||% inside_justs[[i]] groups[i] <- paste("inside", paste(inside_positions[[i]], collapse = "_"), paste(inside_justs[[i]], collapse = "_"), @@ -532,6 +537,7 @@ Guides <- ggproto( ) } } + positions <- positions[keep] inside_positions <- inside_positions[keep] inside_justs <- inside_justs[keep] @@ -595,7 +601,7 @@ Guides <- ggproto( # here, we put `inside_position` in the last, so that it won't break current # implement of patchwork - package_box = function(grobs, position, theme, + package_box = function(grobs, position, theme, inside_position = NULL, inside_just = NULL) { if (is.zero(grobs) || length(grobs) == 0) { return(zeroGrob()) From e381fa3fa6d45d72b9d5bf3cd9e79387acb25c50 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Sat, 30 Nov 2024 02:06:35 +0800 Subject: [PATCH 17/26] code notes --- R/guides-.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index 1643e14aba..b7e0a8550f 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -599,8 +599,9 @@ Guides <- ggproto( grobs }, - # here, we put `inside_position` in the last, so that it won't break current - # implement of patchwork + # here, we put `inside_position` and `inside_just` in the last, so that it + # won't break current implement of patchwork, which depends on the top three + # arguments to collect guides package_box = function(grobs, position, theme, inside_position = NULL, inside_just = NULL) { if (is.zero(grobs) || length(grobs) == 0) { From acbf747270c117036d736ce638fc8b7f1dadeed0 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Wed, 4 Dec 2024 23:55:54 +0800 Subject: [PATCH 18/26] Update R/guides-.R Co-authored-by: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> --- R/guides-.R | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index b7e0a8550f..16cb8d740c 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -522,11 +522,7 @@ Guides <- ggproto( # use inherits from `legend.justification` or `legend.position`, we only # follow the inside elements from the guide theme inside_just <- params[[i]]$theme[["legend.justification.inside"]] - if (is.null(inside_just)) { - inside_justs[[i]] <- default_inside_just - } else { - inside_justs[[i]] <- valid.just(inside_just) - } + inside_justs[[i]] <- valid.just(inside_just %||% default_inside_just) inside_positions[[i]] <- params[[i]]$theme[[ "legend.position.inside" ]] %||% default_inside_position %||% inside_justs[[i]] From 4dd4970d357eddc2ba7b74e86ad18a95be25f4ce Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Wed, 4 Dec 2024 23:57:25 +0800 Subject: [PATCH 19/26] apply suggestion Co-authored-by: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> --- R/guides-.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index 16cb8d740c..c72e4ea094 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -515,8 +515,7 @@ Guides <- ggproto( # we grouped the legends by the positions, for inside legends, they'll be # splitted by the actual inside coordinate groups <- positions - for (i in seq_along(positions)) { - if (identical(positions[i], "inside")) { + for (i in seq_along(positions)[positions == "inside"]) { # the actual inside position and justification can be set in each guide # by `theme` argument, here, we won't use `calc_element()` which will # use inherits from `legend.justification` or `legend.position`, we only From e7cf7de0ec8c877910091ca6593afb76771ec955 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Thu, 5 Dec 2024 01:30:38 +0800 Subject: [PATCH 20/26] avoid modify package_box --- R/guides-.R | 142 +++++++++++++++++++++++-------------------------- R/plot-build.R | 21 ++------ 2 files changed, 73 insertions(+), 90 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index c72e4ea094..e1c13af311 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -514,21 +514,20 @@ Guides <- ggproto( # we grouped the legends by the positions, for inside legends, they'll be # splitted by the actual inside coordinate - groups <- positions - for (i in seq_along(positions)[positions == "inside"]) { + for (i in seq_along(positions)) { + if (identical(positions[i], "inside")) { # the actual inside position and justification can be set in each guide # by `theme` argument, here, we won't use `calc_element()` which will # use inherits from `legend.justification` or `legend.position`, we only # follow the inside elements from the guide theme inside_just <- params[[i]]$theme[["legend.justification.inside"]] - inside_justs[[i]] <- valid.just(inside_just %||% default_inside_just) - inside_positions[[i]] <- params[[i]]$theme[[ - "legend.position.inside" - ]] %||% default_inside_position %||% inside_justs[[i]] - groups[i] <- paste("inside", - paste(inside_positions[[i]], collapse = "_"), - paste(inside_justs[[i]], collapse = "_"), - sep = "_" + inside_justs[i] <- list( + valid.just(inside_just %||% default_inside_just) + ) + inside_positions[i] <- list( + params[[i]]$theme[[ + "legend.position.inside" + ]] %||% default_inside_position %||% inside_justs[[i]] ) } } @@ -536,52 +535,65 @@ Guides <- ggproto( positions <- positions[keep] inside_positions <- inside_positions[keep] inside_justs <- inside_justs[keep] - groups <- groups[keep] # we group the guide legends - locs <- vec_group_loc(groups) - indices <- locs$loc - grobs <- vec_chop(grobs, indices = indices) - names(grobs) <- locs$key - - # for each group, they share the same locations, - # so we only extract the first one of `positions` and `inside_positions` - first_indice <- lapply(indices, `[[`, 1L) - positions <- vec_chop(positions, indices = first_indice) - inside_positions <- vec_chop(inside_positions, indices = first_indice) - inside_justs <- vec_chop(inside_justs, indices = first_indice) + locs <- vec_group_loc(new_data_frame( + set_names( + list(positions, inside_positions, inside_justs), + c("position", "coords", "justs") + ) + )) + grobs <- vec_chop(grobs, indices = locs$loc) + keys <- locs$key # Set spacing 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) - Map( - grobs = grobs, - position = positions, - inside_position = inside_positions, - inside_just = inside_justs, - self$package_box, - MoreArgs = list(theme = theme) - ) + # prepare output + ans <- vector("list", 5L) + names(ans) <- c(.trbl, "inside") + for (i in vec_seq_along(locs)) { + if (identical(position <- keys$position[i], "inside")) { + ans[[position]] <- c( + ans[[position]], + list(self$package_box( + grobs = grobs[[i]], + position = position, + theme = theme + theme( + legend.position.inside = keys$coords[[i]], + legend.justification.inside = keys$justs[[i]] + ) + )) + ) + } else { + ans[[position]] <- self$package_box( + grobs = grobs[[i]], + position = position, theme = theme + ) + } + } + # merge inside grobs into single gtable + if (!is.null(ans$inside)) { + ans$inside <- gtable_add_grob( + gtable(unit(1, "null"), unit(1, "null")), + grobs = ans$inside, + clip = "off", + t = 1L, l = 1L, + name = paste("guide-box-inside", seq_along(ans$inside), sep = "-") + ) + } + ans }, # Render the guides into grobs - draw = function(self, theme, positions = NULL, direction = NULL, + draw = function(self, theme, positions, direction = NULL, params = self$params, guides = self$guides) { - positions <- positions %||% vapply( - params, - function(p) p$position[1] %||% "right", - character(1), USE.NAMES = FALSE - ) + directions <- rep(direction %||% "vertical", length(positions)) if (is.null(direction)) { - directions <- ifelse( - positions %in% c("top", "bottom"), - "horizontal", "vertical" - ) - } else { - directions <- rep(direction, length(positions)) + directions[positions %in% c("top", "bottom")] <- "horizontal" } grobs <- vector("list", length(guides)) @@ -597,8 +609,8 @@ Guides <- ggproto( # here, we put `inside_position` and `inside_just` in the last, so that it # won't break current implement of patchwork, which depends on the top three # arguments to collect guides - package_box = function(grobs, position, theme, - inside_position = NULL, inside_just = NULL) { + package_box = function(grobs, position, theme) { + if (is.zero(grobs) || length(grobs) == 0) { return(zeroGrob()) } @@ -626,36 +638,19 @@ Guides <- ggproto( stretch_x <- any(unlist(lapply(widths, unitType)) == "null") stretch_y <- any(unlist(lapply(heights, unitType)) == "null") + # Global justification of the complete legend box + global_just <- paste0("legend.justification.", position) + global_just <- valid.just(calc_element(global_just, theme)) + if (position == "inside") { - # for backward compatibility, no `inside_just` input - if (is.null(inside_just) || - # `inside_just` is a list of length one - is.null(inside_just <- inside_just[[1L]])) { - global_just <- valid.just( - calc_element("legend.justification.inside", theme) - ) - } else { - global_just <- inside_just - } - global_xjust <- global_just[1] - global_yjust <- global_just[2] - # for backward compatibility, no `inside_position` input - if (is.null(inside_position) || - # `inside_position` is a list of length one - is.null(inside_position <- inside_position[[1L]])) { - x <- global_xjust - y <- global_yjust - } else { - x <- inside_position[1L] - y <- inside_position[2L] - } + # The position of inside legends are set by their justification + inside_position <- theme$legend.position.inside %||% global_just + global_xjust <- inside_position[1] + global_yjust <- inside_position[2] global_margin <- margin() } else { - # Global justification of the complete legend box - global_just <- paste0("legend.justification.", position) - global_just <- valid.just(calc_element(global_just, theme)) - x <- global_xjust <- global_just[1] - y <- global_yjust <- global_just[2] + global_xjust <- global_just[1] + global_yjust <- global_just[2] # Legends to the side of the plot need a margin for justification # relative to the plot panel global_margin <- margin( @@ -697,7 +692,7 @@ Guides <- ggproto( # Set global justification vp <- viewport( - x = x, y = y, just = global_just, + x = global_xjust, y = global_yjust, just = global_just, height = max(heights), width = vp_width ) @@ -735,7 +730,7 @@ Guides <- ggproto( # Set global justification vp <- viewport( - x = x, y = y, just = global_just, + x = global_xjust, y = global_yjust, just = global_just, height = vp_height, width = max(widths) ) @@ -776,7 +771,6 @@ Guides <- ggproto( guides$name <- "guide-box" guides }, - ## Utilities ----------------------------------------------------------------- print = function(self) { diff --git a/R/plot-build.R b/R/plot-build.R index 23db50285b..592e79dac3 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -515,22 +515,11 @@ table_add_legends <- function(table, legends, theme) { # Add manual legend place <- find_panel(table) - inside_legends <- legends[startsWith(names(legends), "inside")] - if (length(inside_legends)) { - for (i in seq_along(inside_legends)) { - table <- gtable_add_grob( - table, inside_legends[[i]], clip = "off", - t = place$t, b = place$b, l = place$l, r = place$r, - name = paste("guide-box-inside", i, sep = "-") - ) - } - } else { # to be consistent with original gtable layout - table <- gtable_add_grob( - table, zeroGrob(), clip = "off", - t = place$t, b = place$b, l = place$l, r = place$r, - name = "guide-box-inside" - ) - } + table <- gtable_add_grob( + table, legends$inside %||% zeroGrob(), clip = "off", + t = place$t, b = place$b, l = place$l, r = place$r, + name = "guide-box-inside" + ) table } From 40f13bf045c0984e67f5bd3d7e02f9515963c57f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 4 Dec 2024 18:57:01 +0100 Subject: [PATCH 21/26] accept snapshot --- .../legend-inside-plot-multiple-positions.svg | 85 +++++++++++++++++++ 1 file changed, 85 insertions(+) create mode 100644 tests/testthat/_snaps/guides/legend-inside-plot-multiple-positions.svg diff --git a/tests/testthat/_snaps/guides/legend-inside-plot-multiple-positions.svg b/tests/testthat/_snaps/guides/legend-inside-plot-multiple-positions.svg new file mode 100644 index 0000000000..22481fa7cf --- /dev/null +++ b/tests/testthat/_snaps/guides/legend-inside-plot-multiple-positions.svg @@ -0,0 +1,85 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + +A +B +C +x +y + +x + + + + + + +A +B +C + +1:3 + + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +legend inside plot, multiple positions + + From a634f2067b36b0059b5fef6bf8b69cfdd7acf734 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Thu, 5 Dec 2024 02:12:06 +0800 Subject: [PATCH 22/26] Update R/guides-.R Co-authored-by: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> --- R/guides-.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index e1c13af311..ffc6942df6 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -514,8 +514,7 @@ Guides <- ggproto( # we grouped the legends by the positions, for inside legends, they'll be # splitted by the actual inside coordinate - for (i in seq_along(positions)) { - if (identical(positions[i], "inside")) { + for (i in seq_along(positions)[positions == "inside"]) { # the actual inside position and justification can be set in each guide # by `theme` argument, here, we won't use `calc_element()` which will # use inherits from `legend.justification` or `legend.position`, we only From 6e41f07f10c24c74a4de8fb3eff90dad42efae36 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Thu, 5 Dec 2024 02:14:26 +0800 Subject: [PATCH 23/26] accept the suggestion --- R/guides-.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index ffc6942df6..7b8eb924fb 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -514,7 +514,7 @@ Guides <- ggproto( # we grouped the legends by the positions, for inside legends, they'll be # splitted by the actual inside coordinate - for (i in seq_along(positions)[positions == "inside"]) { + for (i in which(positions == "inside")) { # the actual inside position and justification can be set in each guide # by `theme` argument, here, we won't use `calc_element()` which will # use inherits from `legend.justification` or `legend.position`, we only @@ -528,8 +528,8 @@ Guides <- ggproto( "legend.position.inside" ]] %||% default_inside_position %||% inside_justs[[i]] ) - } } + positions <- positions[keep] inside_positions <- inside_positions[keep] From df64aa2de1175abe95b6c96feb88668944649c40 Mon Sep 17 00:00:00 2001 From: Yunuuuu Date: Thu, 5 Dec 2024 02:36:38 +0800 Subject: [PATCH 24/26] new bullet --- NEWS.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/NEWS.md b/NEWS.md index 65e8c9fc48..809c2f6575 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # ggplot2 (development version) +* `guide_*()` can now accept two inside legend theme elements: + "legend.position.inside" and "legend.justification.inside", allowing inside + legends to be placed at different positions. Only inside legends with the same + position and justification will be merged. (@Yunuuuu, #6210) * In non-orthogonal coordinate systems (`coord_sf()`, `coord_polar()` and `coord_radial()`), using 'AsIs' variables escape transformation when both `x` and `y` is an 'AsIs' variable (@teunbrand, #6205). From e84a4a4a9fc67f5b28a23dddaa426c9b2fe0b2e2 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 4 Dec 2024 20:08:04 +0100 Subject: [PATCH 25/26] try to linearise logic --- R/guide-legend.R | 2 +- R/guides-.R | 106 ++++++++++++++++++++--------------------------- R/plot-build.R | 15 +++---- 3 files changed, 54 insertions(+), 69 deletions(-) diff --git a/R/guide-legend.R b/R/guide-legend.R index d6e0afe7dc..37aad2e3f0 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -559,7 +559,7 @@ GuideLegend <- ggproto( gt <- gtable_add_grob( gt, elements$background, name = "background", clip = "off", - t = 1, r = -1, b = -1, l = 1, z = -Inf + t = 1, r = -1, b = -1, l =1, z = -Inf ) } gt diff --git a/R/guides-.R b/R/guides-.R index 7b8eb924fb..debb99237e 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -504,46 +504,34 @@ Guides <- ggproto( } # prepare the position of inside legends - default_inside_just <- valid.just( - calc_element("legend.justification.inside", theme) - ) - default_inside_position <- calc_element( - "legend.position.inside", theme + default_inside_just <- calc_element("legend.justification.inside", theme) + default_inside_position <- calc_element("legend.position.inside", theme) + + groups <- data_frame0( + positions = positions, + justs = list(NULL), + coords = list(NULL) ) - inside_justs <- inside_positions <- vector("list", length(positions)) # we grouped the legends by the positions, for inside legends, they'll be # splitted by the actual inside coordinate for (i in which(positions == "inside")) { - # the actual inside position and justification can be set in each guide - # by `theme` argument, here, we won't use `calc_element()` which will - # use inherits from `legend.justification` or `legend.position`, we only - # follow the inside elements from the guide theme - inside_just <- params[[i]]$theme[["legend.justification.inside"]] - inside_justs[i] <- list( - valid.just(inside_just %||% default_inside_just) - ) - inside_positions[i] <- list( - params[[i]]$theme[[ - "legend.position.inside" - ]] %||% default_inside_position %||% inside_justs[[i]] - ) - } - + # the actual inside position and justification can be set in each guide + # by `theme` argument, here, we won't use `calc_element()` which will + # use inherits from `legend.justification` or `legend.position`, we only + # follow the inside elements from the guide theme + just <- params[[i]]$theme[["legend.justification.inside"]] + just <- valid.just(just %||% default_inside_just) + coord <- params[[i]]$theme[["legend.position.inside"]] + coord <- coord %||% default_inside_position %||% just - positions <- positions[keep] - inside_positions <- inside_positions[keep] - inside_justs <- inside_justs[keep] + groups$justs[[i]] <- just + groups$coord[[i]] <- coord + } - # we group the guide legends - locs <- vec_group_loc(new_data_frame( - set_names( - list(positions, inside_positions, inside_justs), - c("position", "coords", "justs") - ) - )) - grobs <- vec_chop(grobs, indices = locs$loc) - keys <- locs$key + groups <- vec_group_loc(vec_slice(groups, keep)) + grobs <- vec_chop(grobs, indices = groups$loc) + names(grobs) <- groups$key$positions # Set spacing theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") @@ -551,39 +539,35 @@ Guides <- ggproto( theme$legend.spacing.x <- calc_element("legend.spacing.x", theme) # prepare output - ans <- vector("list", 5L) - names(ans) <- c(.trbl, "inside") - for (i in vec_seq_along(locs)) { - if (identical(position <- keys$position[i], "inside")) { - ans[[position]] <- c( - ans[[position]], - list(self$package_box( - grobs = grobs[[i]], - position = position, - theme = theme + theme( - legend.position.inside = keys$coords[[i]], - legend.justification.inside = keys$justs[[i]] - ) - )) + for (i in vec_seq_along(groups)) { + adjust <- NULL + position <- groups$key$position[i] + if (position == "inside") { + adjust <- theme( + legend.position.inside = groups$key$coord[[i]], + legend.justification.inside = groups$key$justs[[i]] ) - } else { - ans[[position]] <- self$package_box( - grobs = grobs[[i]], - position = position, theme = theme - ) - } + } + grobs[[i]] <- self$package_box(grobs[[i]], position, theme + adjust) } + # merge inside grobs into single gtable - if (!is.null(ans$inside)) { - ans$inside <- gtable_add_grob( - gtable(unit(1, "null"), unit(1, "null")), - grobs = ans$inside, - clip = "off", - t = 1L, l = 1L, - name = paste("guide-box-inside", seq_along(ans$inside), sep = "-") + is_inside <- names(grobs) == "inside" + if (sum(is_inside) > 1) { + inside <- gtable(unit(1, "npc"), unit(1, "npc")) + inside <- gtable_add_grob( + inside, grobs[is_inside], + t = 1, l = 1, clip = "off", + name = paste0("guide-box-inside-", seq_len(sum(is_inside))) ) + grobs <- grobs[!is_inside] + grobs$inside <- inside } - ans + + # fill in missing guides + grobs[setdiff(c(.trbl, "inside"), names(grobs))] <- list(zeroGrob()) + + grobs }, # Render the guides into grobs diff --git a/R/plot-build.R b/R/plot-build.R index 592e79dac3..873f79a32c 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -448,8 +448,8 @@ table_add_tag <- function(table, label, theme) { table_add_legends <- function(table, legends, theme) { if (is.zero(legends)) { - legends <- rep(list(zeroGrob()), 4) - names(legends) <- .trbl + legends <- rep(list(zeroGrob()), 5) + names(legends) <- c(.trbl, "inside") } # Extract sizes @@ -479,7 +479,7 @@ table_add_legends <- function(table, legends, theme) { table <- gtable_add_cols(table, spacing$right, pos = -1) table <- gtable_add_cols(table, widths$right, pos = -1) table <- gtable_add_grob( - table, legends$right %||% zeroGrob(), clip = "off", + table, legends$right, clip = "off", t = place$t, b = place$b, l = -1, r = -1, name = "guide-box-right" ) @@ -488,7 +488,7 @@ table_add_legends <- function(table, legends, theme) { table <- gtable_add_cols(table, spacing$left, pos = 0) table <- gtable_add_cols(table, widths$left, pos = 0) table <- gtable_add_grob( - table, legends$left %||% zeroGrob(), clip = "off", + table, legends$left, clip = "off", t = place$t, b = place$b, l = 1, r = 1, name = "guide-box-left" ) @@ -499,7 +499,7 @@ table_add_legends <- function(table, legends, theme) { table <- gtable_add_rows(table, spacing$bottom, pos = -1) table <- gtable_add_rows(table, heights$bottom, pos = -1) table <- gtable_add_grob( - table, legends$bottom %||% zeroGrob(), clip = "off", + table, legends$bottom, clip = "off", t = -1, b = -1, l = place$l, r = place$r, name = "guide-box-bottom" ) @@ -508,7 +508,7 @@ table_add_legends <- function(table, legends, theme) { table <- gtable_add_rows(table, spacing$top, pos = 0) table <- gtable_add_rows(table, heights$top, pos = 0) table <- gtable_add_grob( - table, legends$top %||% zeroGrob(), clip = "off", + table, legends$top, clip = "off", t = 1, b = 1, l = place$l, r = place$r, name = "guide-box-top" ) @@ -516,10 +516,11 @@ table_add_legends <- function(table, legends, theme) { # Add manual legend place <- find_panel(table) table <- gtable_add_grob( - table, legends$inside %||% zeroGrob(), clip = "off", + table, legends$inside, clip = "off", t = place$t, b = place$b, l = place$l, r = place$r, name = "guide-box-inside" ) + table } From 6c8b526eade1dba8cdce7f4e356af94deb62977d Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 4 Dec 2024 20:23:47 +0100 Subject: [PATCH 26/26] tweak formatting --- NEWS.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index c0b832b739..dd574ac1aa 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,9 +1,9 @@ # ggplot2 (development version) * `guide_*()` can now accept two inside legend theme elements: - "legend.position.inside" and "legend.justification.inside", allowing inside + `legend.position.inside` and `legend.justification.inside`, allowing inside legends to be placed at different positions. Only inside legends with the same - position and justification will be merged. (@Yunuuuu, #6210) + position and justification will be merged (@Yunuuuu, #6210). * New stat: `stat_manual()` for arbitrary computations (@teunbrand, #3501) * Reversal of a dimension, typically 'x' or 'y', is now controlled by the `reverse` argument in `coord_cartesian()`, `coord_fixed()`, `coord_radial()`