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,42 +485,111 @@ 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
+    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]]
+        )
+    }
+
+
+    positions <- positions[keep]
+    inside_positions <- inside_positions[keep]
+    inside_justs <- inside_justs[keep]
+
+    # 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
 
     # 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 = names(grobs),
-      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,
-                  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)
-    )
-    positions <- factor(positions, levels = c(.trbl, "inside"))
-
     directions <- rep(direction %||% "vertical", length(positions))
     if (is.null(direction)) {
       directions[positions %in% c("top", "bottom")] <- "horizontal"
@@ -529,14 +598,16 @@ 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]]
       )
     }
-    keep <- !vapply(grobs, is.zero, logical(1))
-    split(grobs[keep], positions[keep])
+    grobs
   },
 
+  # 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) {
 
     if (is.zero(grobs) || length(grobs) == 0) {
@@ -699,7 +770,6 @@ Guides <- ggproto(
     guides$name <- "guide-box"
     guides
   },
-
   ## Utilities -----------------------------------------------------------------
 
   print = function(self) {

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,18 @@ 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",
+    table, legends$inside %||% 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", {