multiple inside guide box with different position

R/guide-colorbar.R

@@ -212,19 +212,20 @@ 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"
   ),
 
   extract_key = function(scale, aesthetic, ...) {

R/guide-legend.R

@@ -169,18 +169,19 @@ 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"
   ),
 
   extract_params = function(scale, params,
@@ -559,9 +560,16 @@ 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
       )
     }
+
+    # 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
   }
 )

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,28 @@ 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]]
       )
+      # 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 = "_"
+        )
+      }
     }
-    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)
+
+    # we grouped the legends by the positions
+    # for inside legends, they'll be splitted by the actual inside coordinate
     split(grobs[keep], positions[keep])
   },
 
@@ -546,8 +562,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
@@ -566,19 +584,27 @@ 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_position <- theme$legend.position.inside %||% global_just
-      global_xjust  <- inside_position[1]
-      global_yjust  <- inside_position[2]
-      global_margin <- margin()
-    } else {
+    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_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
       # relative to the plot panel
       global_margin <- margin(
@@ -620,7 +646,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 +684,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)
       )

R/plot-build.R

@@ -515,12 +515,22 @@ 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"))
+  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, zeroGrob(), clip = "off",
+      t = place$t, b = place$b, l = place$l, r = place$r,
+      name = "guide-box-inside"
+    )
+  }
   table
 }
 

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", {