multiple inside guide box with different position

Author: Yunuuuu

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, ...) {

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

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)
       )

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
 }