Move coord clipping responsibility from facet to coord (#5953)

* move panel assembly to coord

* move panel clipping responsibility from facets to coords

* coord_radial uses clipping path

* only apply clipping mask when possibly supported

* add news bullet

* turn on strip clipping by default

* remove superfluous `clip` argument

* add another bullet

* reminder for the future

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(