multiple inside guide box with different position

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

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,76 @@ 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_just <- valid.just(
+      calc_element("legend.justification.inside", theme)
+    )
+    default_inside_position <- calc_element(
+      "legend.position.inside", theme
+    )
+    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 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"]]
+        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 = "_"),
+          sep = "_"
+        )
+      }
+    }
+
+    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)
 
     # Set spacing
     theme$legend.spacing   <- theme$legend.spacing %||% unit(0.5, "lines")
@@ -502,43 +563,47 @@ Guides <- ggproto(
 
     Map(
       grobs    = grobs,
-      position = names(grobs),
+      position = positions,
+      inside_position = inside_positions,
+      inside_just = inside_justs,
       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 = NULL, direction = NULL,
                   params = self$params,
                   guides = self$guides) {
-    positions <- vapply(
+    positions <- positions %||% vapply(
       params,
-      function(p) p$position[1] %||% default_position,
-      character(1)
+      function(p) p$position[1] %||% "right",
+      character(1), USE.NAMES = FALSE
     )
-    positions <- factor(positions, levels = c(.trbl, "inside"))
-
-    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))
     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]]
       )
     }
-    keep <- !vapply(grobs, is.zero, logical(1))
-    split(grobs[keep], positions[keep])
+    grobs
   },
 
-  package_box = function(grobs, position, theme) {
-
+  # 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) {
       return(zeroGrob())
     }
@@ -566,19 +631,36 @@ 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 {
+      # 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]
+      }
+      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 +702,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 +740,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

@@ -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
@@ -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,19 +508,29 @@ 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"
   )
 
   # 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 <- 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
 }
 

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, 5))
+  expect_true(is.zero(guides))
 })
 
 test_that("bins can be parsed by guides for all scale types", {
@@ -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", {