diff --git a/R/coord-.R b/R/coord-.R index 6b0470e39e..5987f27b12 100644 --- a/R/coord-.R +++ b/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)) } ) diff --git a/R/coord-radial.R b/R/coord-radial.R index bc933ea1d7..2a0948e9c1 100644 --- a/R/coord-radial.R +++ b/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) }, diff --git a/R/facet-.R b/R/facet-.R index 16647b5f07..1e8331f3ce 100644 --- a/R/facet-.R +++ b/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) + }) +} diff --git a/R/facet-null.R b/R/facet-null.R index 26b610fdfa..45e4472f8e 100644 --- a/R/facet-null.R +++ b/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 diff --git a/R/layout.R b/R/layout.R index 92a28216d7..e8cb5df377 100644 --- a/R/layout.R +++ b/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, diff --git a/R/theme-defaults.R b/R/theme-defaults.R index 6f32012cd0..c3b07397d4 100644 --- a/R/theme-defaults.R +++ b/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), diff --git a/R/theme-elements.R b/R/theme-elements.R index dad3927a16..a9fc015939 100644 --- a/R/theme-elements.R +++ b/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"), diff --git a/R/theme.R b/R/theme.R index 33ff8b423e..a82795871a 100644 --- a/R/theme.R +++ b/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, diff --git a/R/utilities-grid.R b/R/utilities-grid.R index a935d5b38f..5a2c5d6bea 100644 --- a/R/utilities-grid.R +++ b/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)) + } +}