theme gains a new element panel.merge to control whether to merge panel area into single gTree

Author: Yunuuuu

R/coord-.R

@@ -211,17 +211,7 @@ Coord <- ggproto("Coord",
   },
 
   draw_panel = function(self, panel, params, theme) {
-    fg <- self$render_fg(params, theme)
-    bg <- self$render_bg(params, theme)
-    if (isTRUE(theme$panel.ontop)) {
-      panel <- list2(!!!panel, bg, fg)
-    } else {
-      panel <- list2(bg, !!!panel, fg)
-    }
-    gTree(
-      children = inject(gList(!!!panel)),
-      vp = viewport(clip = self$clip)
-    )
+    insert_vp(panel, viewport(clip = self$clip))
   }
 )
 

R/coord-radial.R

@@ -370,7 +370,6 @@ CoordRadial <- ggproto("CoordRadial", Coord,
     )
   },
 
-
   draw_panel = function(self, panel, params, theme) {
     clip_support <- check_device("clippingPaths", "test", maybe = TRUE)
     if (self$clip == "on" && !isFALSE(clip_support)) {
@@ -383,10 +382,7 @@ CoordRadial <- ggproto("CoordRadial", Coord,
       # Note that clipping path is applied to panel without coord
       # foreground/background (added in parent method).
       # These may contain decorations that needn't be clipped
-      panel <- list(gTree(
-        children = inject(gList(!!!panel)),
-        vp = viewport(clip = clip_path)
-      ))
+      panel <- insert_vp(panel, viewport(clip = clip_path))
     }
     ggproto_parent(Coord, self)$draw_panel(panel, params, theme)
   },

R/facet-.R

@@ -155,8 +155,12 @@ Facet <- ggproto("Facet", NULL,
       }
     }
 
+    facet_bg <- self$draw_back(data, layout, x_scales, y_scales, theme, params)
+    facet_fg <- self$draw_front(data, layout, x_scales, y_scales, theme, params)
+
     table <- self$init_gtable(
-      panels, layout, theme, ranges, params,
+      panels, facet_bg, facet_fg, 
+      coord, layout, theme, ranges, params,
       aspect_ratio = aspect_ratio %||% coord$aspect(ranges[[1]])
     )
 
@@ -200,13 +204,12 @@ Facet <- ggproto("Facet", NULL,
   finish_data = function(data, layout, x_scales, y_scales, params) {
     data
   },
-  init_gtable = function(panels, layout, theme, ranges, params,
+  init_gtable = function(panels, facet_bg, facet_fg, 
+                         coord, layout, theme, ranges, params, 
                          aspect_ratio = NULL) {
 
-    # Initialise matrix of panels
+    # gtable dimentions
     dim   <- c(max(layout$ROW), max(layout$COL))
-    table <- matrix(list(zeroGrob()), dim[1], dim[2])
-    table[cbind(layout$ROW, layout$COL)] <- panels
 
     # Set initial sizes
     widths  <- unit(rep(1, dim[2]), "null")
@@ -227,20 +230,56 @@ Facet <- ggproto("Facet", NULL,
     }
 
     # Build gtable
-    table <- gtable_matrix(
-      "layout", table,
-      widths = widths, heights = heights,
-      respect = !is.null(aspect_ratio),
-      clip = "off", z = matrix(1, dim[1], dim[2])
-    )
-
-    # Set panel names
-    table$layout$name <- paste(
-      "panel",
-      rep(seq_len(dim[2]), each = dim[1]),
-      rep(seq_len(dim[1]), dim[2]),
-      sep = "-"
+    table <- gtable(widths = widths, heights = heights, 
+        name = "layout", respect = !is.null(aspect_ratio)
     )
+    if (isTRUE(theme$panel.merge %||% TRUE)) {
+      panels <- merge_panels(panels, facet_bg, facet_fg, ranges, theme, coord)
+      table <- gtable_add_grob(
+        table, panels,
+        t = layout$ROW,
+        l = layout$COL,
+        z = 1,
+        name = paste("panel", layout$COL, layout$ROW, sep = "-")
+      )
+    } else {
+      coord_fg <- lapply(seq_along(panels[[1]]), function(i) {
+        coord_fg <- coord$render_fg(ranges[[i]], theme)
+        ggproto_parent(Coord, coord)$draw_panel(coord_fg, ranges[[i]], theme)
+      })
+      coord_bg <- lapply(seq_along(panels[[1]]), function(i) {
+        coord_bg <- coord$render_bg(ranges[[i]], theme)
+        ggproto_parent(Coord, coord)$draw_panel(coord_bg, ranges[[i]], theme)
+      })
+      names <- paste("layer", seq_along(panels), sep = "-")
+      panels <- c(list(facet_bg), panels, list(facet_fg))
+      names <- c("facet-bg", names, "facet-fg")
+      panels <- lapply(panels, function(panel) {
+        # let Coord modify the panel
+        lapply(seq_along(panel), function(i) {
+          coord$draw_panel(panel[[i]], ranges[[i]], theme)
+        })
+      })
+
+      if (isTRUE(theme$panel.ontop)) {
+        panels <- c(panels, list(coord_bg), list(coord_fg))
+        names <- c(names, "coord-bg", "coord-fg")
+      } else {
+        panels <- c(list(coord_bg), panels, list(coord_fg))
+        names <- c("coord-bg", names, "coord-fg")
+      }
+      for (i in seq_along(panels)) {
+        table <- gtable_add_grob(
+          table, panels[[i]],
+          t = layout$ROW,
+          l = layout$COL,
+          # when drawing, the grob with the same `z` will be drawn in the
+          # ordering they added
+          z = 1,
+          name = paste("panel", layout$COL, layout$ROW, names[[i]], sep = "-")
+        )
+      }
+    }
 
     # Add spacing between panels
     spacing <- lapply(
@@ -898,7 +937,7 @@ map_facet_data <- function(data, layout, params) {
   # Compute faceting values
   facet_vals <- eval_facets(vars, data, params$.possible_columns)
 
-  include_margins <- !isFALSE(params$margin %||% FALSE) &&
+  include_margins <- !isFALSE(params$margins %||% FALSE) &&
     nrow(facet_vals) == nrow(data) && grid_layout
   if (include_margins) {
     # Margins are computed on evaluated faceting values (#1864).
@@ -964,3 +1003,33 @@ map_facet_data <- function(data, layout, params) {
 
   data
 }
+
+merge_panels <- function(panels, facet_bg, facet_fg, ranges, theme, coord) {
+  lapply(seq_along(panels[[1]]), function(i) {
+    # merge panel
+    panel <- lapply(panels, `[[`, i)
+    panel <- c(facet_bg[i], panel, facet_fg[i])
+    panel <- gTree(children = inject(gList(!!!panel)))
+    
+    # let Coord modify the panel
+    panel <- coord$draw_panel(panel, ranges[[i]], theme)
+    
+    # in the end, we add foreground and background
+    # we always ensure the `fg` and `bg` follow the Coord `clip` argument
+    coord_fg <- coord$render_fg(ranges[[i]], theme)
+    coord_fg <- ggproto_parent(Coord, coord)$draw_panel(
+      coord_fg, ranges[[i]], theme
+    )
+    coord_bg <- coord$render_bg(ranges[[i]], theme)
+    coord_bg <- ggproto_parent(Coord, coord)$draw_panel(
+      coord_bg, ranges[[i]], theme
+    )
+    if (isTRUE(theme$panel.ontop)) {
+      panel <- list(panel, coord_bg, coord_fg)
+    } else {
+      panel <- list(coord_bg, panel, coord_fg)
+    }
+    panel <- gTree(children = inject(gList(!!!panel)))
+    ggname(paste("panel", i, sep = "-"), panel)
+  })
+}

R/facet-null.R

@@ -42,8 +42,13 @@ FacetNull <- ggproto("FacetNull", Facet,
     data$PANEL <- factor(1)
     data
   },
-  draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) {
+  draw_panels = function(self, panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) {
 
+    facet_bg <- self$draw_back(data, layout, x_scales, y_scales, theme, params)
+    facet_fg <- self$draw_front(data, layout, x_scales, y_scales, theme, params)
+
+    # For FacetNull, we always merege the panel area
+    panels <- merge_panels(panels, facet_bg, facet_fg, ranges, theme, coord)
     range <- ranges[[1]]
 
     # Figure out aspect ratio

R/layout.R

@@ -60,29 +60,7 @@ Layout <- ggproto("Layout", NULL,
   # Assemble the facet fg & bg, the coord fg & bg, and the layers
   # Returns a gtable
   render = function(self, panels, data, theme, labels) {
-    facet_bg <- self$facet$draw_back(data,
-      self$layout,
-      self$panel_scales_x,
-      self$panel_scales_y,
-      theme,
-      self$facet_params
-    )
-    facet_fg <- self$facet$draw_front(
-      data,
-      self$layout,
-      self$panel_scales_x,
-      self$panel_scales_y,
-      theme,
-      self$facet_params
-    )
-
     # Draw individual panels, then assemble into gtable
-    panels <- lapply(seq_along(panels[[1]]), function(i) {
-      panel <- lapply(panels, `[[`, i)
-      panel <- c(facet_bg[i], panel, facet_fg[i])
-      panel <- self$coord$draw_panel(panel, self$panel_params[[i]], theme)
-      ggname(paste("panel", i, sep = "-"), panel)
-    })
     plot_table <- self$facet$draw_panels(
       panels,
       self$layout,

R/theme-defaults.R

@@ -231,6 +231,7 @@ theme_grey <- function(base_size = 11, base_family = "",
     panel.spacing.x =    NULL,
     panel.spacing.y =    NULL,
     panel.ontop    =     FALSE,
+    panel.merge    =     TRUE,
 
     strip.background =   element_rect(fill = col_mix(ink, paper, 0.854), colour = NA),
     strip.clip =         "on",
@@ -567,6 +568,7 @@ theme_void <- function(base_size = 11, base_family = "",
     strip.switch.pad.wrap = rel(0.5),
     strip.background =   element_blank(),
     panel.ontop =        FALSE,
+    panel.merge =        TRUE,
     panel.spacing =      NULL,
     panel.background =   element_blank(),
     panel.border =       element_blank(),
@@ -713,6 +715,7 @@ theme_test <- function(base_size = 11, base_family = "",
     panel.spacing.x =    NULL,
     panel.spacing.y =    NULL,
     panel.ontop    =     FALSE,
+    panel.merge    =     TRUE,
 
     strip.background =   element_rect(
                            fill   = col_mix(ink, paper, 0.851),

R/theme-elements.R

@@ -758,6 +758,7 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) {
   panel.grid.minor.x  = el_def("element_line", "panel.grid.minor"),
   panel.grid.minor.y  = el_def("element_line", "panel.grid.minor"),
   panel.ontop         = el_def("logical"),
+  panel.merge         = el_def("logical"),
   panel.widths        = el_def("unit"),
   panel.heights       = el_def("unit"),
 

R/theme.R

@@ -439,6 +439,7 @@ theme <- function(...,
                   panel.grid.minor.x,
                   panel.grid.minor.y,
                   panel.ontop,
+                  panel.merge,
                   panel.widths,
                   panel.heights,
                   plot.background,

R/utilities-grid.R

@@ -70,3 +70,11 @@ height_cm <- function(x) {
     cli::cli_abort("Don't know how to get height of {.cls {class(x)}} object")
   }
 }
+
+insert_vp <- function(grob, vp) {
+  if (is.null(grob$vp)) {
+    grid::editGrob(grob, vp = vp)
+  } else {
+    grid::editGrob(grob, vp = grid::vpStack(grob$vp, vp))
+  }
+}