Move coord clipping responsibility from facet to coord

NEWS.md

@@ -1,5 +1,12 @@
 # ggplot2 (development version)
 
+* `coord_radial(clip = "on")` clips to the panel area when the graphics device
+  supports clipping paths (@teunbrand, #5952).
+* (internal) Panel clipping responsibility moved from Facet class to Coord 
+  class through new `Coord$draw_panel()` method.
+* `theme(strip.clip)` now defaults to `"on"` and is independent of Coord 
+  clipping (@teunbrand, 5952).
+* (internal) rearranged the code of `Facet$draw_paensl()` method (@teunbrand).
 * Axis labels are now justified across facet panels (@teunbrand, #5820)
 * Fixed bug in `stat_function()` so x-axis title now produced automatically 
   when no data added. (@phispu, #5647).

R/coord-.R

@@ -208,6 +208,20 @@ Coord <- ggproto("Coord",
   # used as a fudge for CoordFlip and CoordPolar
   modify_scales = function(scales_x, scales_y) {
     invisible()
+  },
+
+  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)
+    )
   }
 )
 

R/coord-radial.R

@@ -409,6 +409,27 @@ 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)) {
+      clip_path <- data_frame0(
+        x = c(Inf, Inf, -Inf, -Inf),
+        y = c(Inf, -Inf, -Inf, Inf)
+      )
+      clip_path <- coord_munch(self, clip_path, params, is_closed = TRUE)
+      clip_path <- polygonGrob(clip_path$x, clip_path$y)
+      # 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)
+      ))
+    }
+    ggproto_parent(Coord, self)$draw_panel(panel, params, theme)
+  },
+
   labels = function(self, labels, panel_params) {
     # `Layout$resolve_label()` doesn't know to look for theta/r/r.sec guides,
     # so we'll handle title propagation here.

R/facet-.R

@@ -153,8 +153,7 @@ Facet <- ggproto("Facet", NULL,
 
     table <- self$init_gtable(
       panels, layout, theme, ranges, params,
-      aspect_ratio = aspect_ratio %||% coord$aspect(ranges[[1]]),
-      clip = coord$clip
+      aspect_ratio = aspect_ratio %||% coord$aspect(ranges[[1]])
     )
 
     table <- self$attach_axes(table, layout, ranges, coord, theme, params)
@@ -198,7 +197,7 @@ Facet <- ggproto("Facet", NULL,
     data
   },
   init_gtable = function(panels, layout, theme, ranges, params,
-                         aspect_ratio = NULL, clip = "on") {
+                         aspect_ratio = NULL) {
 
     # Initialise matrix of panels
     dim   <- c(max(layout$ROW), max(layout$COL))
@@ -228,7 +227,7 @@ Facet <- ggproto("Facet", NULL,
       "layout", table,
       widths = widths, heights = heights,
       respect = !is.null(aspect_ratio),
-      clip = clip, z = matrix(1, dim[1], dim[2])
+      clip = "off", z = matrix(1, dim[1], dim[2])
     )
 
     # Set panel names

R/facet-grid-.R

@@ -404,13 +404,13 @@ FacetGrid <- ggproto("FacetGrid", Facet,
       space <- if (!inside_x & table_has_grob(table, "axis-b")) padding
       table <- seam_table(
         table, strips$x$bottom, side = "bottom", name = "strip-b",
-        shift = shift_x, z = 2, clip = "on", spacing = space
+        shift = shift_x, z = 2, clip = "off", spacing = space
       )
     } else {
       space <- if (!inside_x & table_has_grob(table, "axis-t")) padding
       table <- seam_table(
         table, strips$x$top, side = "top", name = "strip-t",
-        shift = shift_x, z = 2, clip = "on", spacing = space
+        shift = shift_x, z = 2, clip = "off", spacing = space
       )
     }
 
@@ -422,13 +422,13 @@ FacetGrid <- ggproto("FacetGrid", Facet,
       space <- if (!inside_y & table_has_grob(table, "axis-l")) padding
       table <- seam_table(
         table, strips$y$left, side = "left", name = "strip-l",
-        shift = shift_y, z = 2, clip = "on", spacing = space
+        shift = shift_y, z = 2, clip = "off", spacing = space
       )
     } else {
       space <- if (!inside_y & table_has_grob(table, "axis-r")) padding
       table <- seam_table(
         table, strips$y$right, side = "right", name = "strip-r",
-        shift = shift_y, z = 2, clip = "on", spacing = space
+        shift = shift_y, z = 2, clip = "off", spacing = space
       )
     }
     table

R/facet-null.R

@@ -63,11 +63,10 @@ FacetNull <- ggproto("FacetNull", Facet,
     grob_widths <- unit.c(grobWidth(axis_v$left), unit(1, "null"), grobWidth(axis_v$right))
     grob_heights <- unit.c(grobHeight(axis_h$top), unit(abs(aspect_ratio), "null"), grobHeight(axis_h$bottom))
     grob_names <- c("spacer", "axis-l", "spacer", "axis-t", "panel", "axis-b", "spacer", "axis-r", "spacer")
-    grob_clip <- c("off", "off", "off", "off", coord$clip, "off", "off", "off", "off")
 
     layout <- gtable_matrix("layout", all,
       widths = grob_widths, heights = grob_heights,
-      respect = respect, clip = grob_clip,
+      respect = respect, clip = "off",
       z = z_matrix
     )
     layout$layout$name <- grob_names

R/facet-wrap.R

@@ -405,7 +405,7 @@ FacetWrap <- ggproto("FacetWrap", Facet,
     shift  <- if (inside) shift[1] else shift[2]
     size   <- unit(size, "cm")
 
-    table <- weave(table, mat, shift, size, name = prefix, z = 2, clip = "on")
+    table <- weave(table, mat, shift, size, name = prefix, z = 2, clip = "off")
 
     if (!inside) {
       axes  <- grepl(paste0("axis-", pos), table$layout$name)

R/layout.R

@@ -80,19 +80,8 @@ Layout <- ggproto("Layout", NULL,
     panels <- lapply(seq_along(panels[[1]]), function(i) {
       panel <- lapply(panels, `[[`, i)
       panel <- c(facet_bg[i], panel, facet_fg[i])
-
-      coord_fg <- self$coord$render_fg(self$panel_params[[i]], theme)
-      coord_bg <- self$coord$render_bg(self$panel_params[[i]], theme)
-      if (isTRUE(theme$panel.ontop)) {
-        panel <- c(panel, list(coord_bg), list(coord_fg))
-      } else {
-        panel <- c(list(coord_bg), panel, list(coord_fg))
-      }
-
-      ggname(
-        paste("panel", i, sep = "-"),
-        gTree(children = inject(gList(!!!panel)))
-      )
+      panel <- self$coord$draw_panel(panel, self$panel_params[[i]], theme)
+      ggname(paste("panel", i, sep = "-"), panel)
     })
     plot_table <- self$facet$draw_panels(
       panels,

R/theme-defaults.R

@@ -212,7 +212,7 @@ theme_grey <- function(base_size = 11, base_family = "",
     panel.ontop    =     FALSE,
 
     strip.background =   element_rect(fill = "grey85", colour = NA),
-    strip.clip =         "inherit",
+    strip.clip =         "on",
     strip.text =         element_text(
                            colour = "grey10",
                            size = rel(0.8),
@@ -511,7 +511,7 @@ theme_void <- function(base_size = 11, base_family = "",
     legend.box.margin =  rel(0),
     legend.box.spacing = unit(0.2, "cm"),
     legend.ticks.length = rel(0.2),
-    strip.clip =         "inherit",
+    strip.clip =         "on",
     strip.text =         element_text(size = rel(0.8)),
     strip.switch.pad.grid = rel(0.5),
     strip.switch.pad.wrap = rel(0.5),
@@ -643,7 +643,7 @@ theme_test <- function(base_size = 11, base_family = "",
     panel.ontop    =     FALSE,
 
     strip.background =   element_rect(fill = "grey85", colour = "grey20"),
-    strip.clip =         "inherit",
+    strip.clip =         "on",
     strip.text =         element_text(
                            colour = "grey10",
                            size = rel(0.8),

tests/testthat/test-coord-polar.R

@@ -158,6 +158,9 @@ test_that("bounding box calculations are sensible", {
 
 # Visual tests ------------------------------------------------------------
 
+#TODO: Once {vdiffr} supports non-rectangular clipping paths, we should add a
+# test for `coord_radial(clip = "on")`'s ability to clip to the sector
+
 test_that("polar coordinates draw correctly", {
   theme <- theme_test() +
     theme(