rggplot2facetclipping
control per-axis ggplot2 clipping
This is an extension beyond a previous question, where the goal was to set different limits for each facet. The code from that question is stored in a gist, and has been in production since.
A quick demo with sample data:
set.seed(42)
dat <- data.frame(x = seq(0,1,len=101), y = cumsum(runif(101,-1,1)), z=sample(1:3, size=101, replace=TRUE))
dat$y <- dat$y * dat$z
dat$y[50] <- 99
dat$z[50] <- 2L
lims <- data.frame(z=1:3, ymin=0, ymax=c(10,25,30))
ggplot(dat, aes(x, y)) +
facet_grid(z ~ ., switch="both", scales="free_y") +
scale_x_continuous(expand = c(0, 0)) +
geom_line() +
coord_cartesian_panels(panel_limits = lims, clip = "on")
I now have a need to add geom_labels to the right side of the plot, outside of plot region. Edit: multiple labels per facet, with colors (whose order is inconsistent between facets). Doing this is relatively straight-forward: place the label at the edge of the screen, extend the theme's plot.margin, and turn off clipping. Unfortunately, as you might imagine with the two excursions in facets 2 and 3, disabling clipping is a concern.
summ <- aggregate(y ~ z, dat, FUN = function(z) c(lo=mean(z)-3, hi=mean(z)+3)) |>
do.call(data.frame, args = _) |>
reshape2::melt("z", variable.name = "ign", value.name = "y") |>
transform(lbl = sprintf("%0.03f", y)) |>
transform(fill = factor(ave(z, z, FUN = function(ign) sample(seq_along(ign)))))
ggplot(dat, aes(x, y)) +
facet_grid(z ~ ., switch="both", scales="free_y") +
scale_x_continuous(expand = c(0, 0)) +
geom_line() +
geom_label(x = 1, aes(y = y, label = lbl, fill = fill), data = summ, hjust = -0.1) +
coord_cartesian_panels(panel_limits = lims, clip = "off") +
theme(plot.margin = unit(c(0.5, 0.65 * max(nchar(summ$lbl)), 0.5, 0.5), "char")) +
scale_fill_discrete(guide = "none")
I supposed there are three possible ways to resolve this:
Find another way to add the labels on the right side that does not require disabling clipping. To be clear, theming (background, axis lines/ticks/labels, etc) should not be affected by this. There are many other components to these plots here, I need the plot region to "stop" cleanly before the labels begin.
Find a way to clip on the
yaxis and not thex. In this case I have "strict" control over the x-values so am not as concerned about running amuck on either the left or right side.Incorporate
oobuse (e.g.,scales::oob_squish) into theggprotouse withincoord_cartesian_panels.Something else?
Solution
(I suppose there are reasons not to consider plotting the labels separately & combining the results together using one of the usual suspects such as cowplot, patchwork, etc.)
I wrote a modified version of FacetGrid that could accept separate clipping instructions for each layer. Combine that with specifying clip = c("on", "off") in coord_cartesian_panels seems to work.
Note: having a legend positioned to the right of the plot (i.e. default legend position) will mess up the appearance, but I'd consider that an intrinsic part of the way ggplot grobs are laid out. Since the use case here doesn't place a legend on the right, I assume it's not a key requirement for now.
Demonstration with same use case in the question:
ggplot(dat, aes(x, y)) +
facet_grid2(z ~ ., switch="both", scales="free_y") +
scale_x_continuous(expand = c(0, 0)) +
geom_line() +
geom_label(x = 1, aes(y = y, label = lbl, fill = fill), data = summ, hjust = -0.1) +
coord_cartesian_panels(panel_limits = lims, clip = c("on", "off")) +
theme(plot.margin = unit(c(0.5, 0.65 * max(nchar(summ$lbl)), 0.5, 0.5), "char")) +
scale_fill_discrete(guide = "none")
Further demonstration for layer-specific clipping by adding another geom layer, but this one clipped at the edge:
ggplot(dat, aes(x, y)) +
facet_grid2(z ~ ., switch="both", scales="free_y") +
scale_x_continuous(expand = c(0, 0)) +
geom_line() +
geom_label(x = 1, aes(y = y, label = lbl, fill = fill), data = summ, hjust = -0.1) +
geom_label(x = 1, aes(y = y-5, label = lbl, fill = fill), data = summ, hjust = 0.5, alpha = 0.5) +
coord_cartesian_panels(panel_limits = lims, clip = c("on", "off", "on")) +
theme(plot.margin = unit(c(0.5, 0.65 * max(nchar(summ$lbl)), 0.5, 0.5), "char")) +
scale_fill_discrete(guide = "none")
Code for facet_grid2 / FacetGrid2 (change from original is mainly a chunk in the middle of the latter's draw_panels function, to allow separate clipping options for different geom layers; everything else is inherited directly from my current version of ggplot2, which is 3.4.2):
library(rlang)
FacetGrid2 <- ggproto(
"FacetGrid2", ggplot2::FacetGrid,
draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) {
if ((params$free$x || params$free$y) && !coord$is_free()) {
cli::cli_abort("{.fn {snake_class(coord)}} doesn't support free scales")
}
cols <- which(layout$ROW == 1)
rows <- which(layout$COL == 1)
axes <- render_axes(ranges[cols], ranges[rows], coord, theme, transpose = TRUE)
col_vars <- ggplot2:::unique0(layout[names(params$cols)])
row_vars <- ggplot2:::unique0(layout[names(params$rows)])
# Adding labels metadata, useful for labellers
attr(col_vars, "type") <- "cols"
attr(col_vars, "facet") <- "grid"
attr(row_vars, "type") <- "rows"
attr(row_vars, "facet") <- "grid"
strips <- render_strips(col_vars, row_vars, params$labeller, theme)
aspect_ratio <- theme$aspect.ratio
if (!is.null(aspect_ratio) && (params$space_free$x || params$space_free$y)) {
cli::cli_abort("Free scales cannot be mixed with a fixed aspect ratio")
}
if (is.null(aspect_ratio) && !params$free$x && !params$free$y) {
aspect_ratio <- coord$aspect(ranges[[1]])
}
if (is.null(aspect_ratio)) {
aspect_ratio <- 1
respect <- FALSE
} else {
respect <- TRUE
}
ncol <- max(layout$COL)
nrow <- max(layout$ROW)
if (params$space_free$x) {
ps <- layout$PANEL[layout$ROW == 1]
widths <- vapply(ps, function(i) diff(ranges[[i]]$x.range), numeric(1))
panel_widths <- unit(widths, "null")
} else {
panel_widths <- rep(unit(1, "null"), ncol)
}
if (params$space_free$y) {
ps <- layout$PANEL[layout$COL == 1]
heights <- vapply(ps, function(i) diff(ranges[[i]]$y.range), numeric(1))
panel_heights <- unit(heights, "null")
} else {
panel_heights <- rep(unit(1 * abs(aspect_ratio), "null"), nrow)
}
# changes from here onwards
relevant.panel.children <- with(panels[[1]],
which(!grepl("grill|NULL|zeroGrob", childrenOrder)))
if(length(coord$clip) == 1) {
panel.layer.grouping <- list(seq_along(panels[[1]]$childrenOrder))
} else if (length(coord$clip) == length(relevant.panel.children)) {
panel.layer.grouping <- lapply(relevant.panel.children, function(n) n)
panel.layer.grouping[[1]] <- seq_len(panel.layer.grouping[[1]])
panel.layer.grouping[[length(relevant.panel.children)]] <- seq(panel.layer.grouping[[length(relevant.panel.children)]],
length(panels[[1]]$childrenOrder))
} else {
message("Clipping instruction cannot be matched unambiguously to layers.")
break()
}
by.layer.clip.info <- coord$clip
panel_table <- vector("list", length = length(by.layer.clip.info))
for(i in seq_along(by.layer.clip.info)) {
panels_by_layer <- lapply(panels,
function(p) p$children[panel.layer.grouping[[i]]])
panel_table_by_layer <- matrix(panels_by_layer, nrow = nrow, ncol = ncol, byrow = TRUE)
panel_table_by_layer <- gtable::gtable_matrix(paste("layout", i, sep = "-"), panel_table_by_layer,
panel_widths, panel_heights, respect = respect,
clip = by.layer.clip.info[[i]],
z = matrix(1, ncol = ncol, nrow = nrow))
panel_table[[i]] <- panel_table_by_layer
}
panel_table_combined <- panel_table[[1]]
if(length(by.layer.clip.info) > 1) {
for(i in seq(2, length(by.layer.clip.info))) {
for(j in seq_len(nrow(panel_table[[i]]))) {
grob.dimensions <- panel_table[[i]]$layout[j, ]
panel_table_combined <- gtable::gtable_add_grob(panel_table_combined,
list(panel_table[[i]]$grobs[[j]]),
t = grob.dimensions[["t"]],
l = grob.dimensions[["l"]],
b = grob.dimensions[["b"]],
r = grob.dimensions[["r"]],
z = grob.dimensions[["z"]],
clip = grob.dimensions[["clip"]],
name = grob.dimensions[["name"]])
}
}
}
panel_table <- panel_table_combined
layout.names <- paste0('panel-', rep(seq_len(nrow), ncol), '-', rep(seq_len(ncol), each = nrow))
if(length(layout.names) == nrow(panel_table$layout)) {
panel_table$layout$name <- layout.names
} else {
panel_table$layout$name <- paste(rep(layout.names, times = length(by.layer.clip.info)),
rep(seq_along(by.layer.clip.info), each = length(layout.names)),
sep = "-")
}
# no changes after this point
panel_table <- gtable::gtable_add_col_space(panel_table,
theme$panel.spacing.x %||% theme$panel.spacing)
panel_table <- gtable::gtable_add_row_space(panel_table,
theme$panel.spacing.y %||% theme$panel.spacing)
# Add axes
panel_table <- gtable::gtable_add_rows(panel_table, max_height(axes$x$top), 0)
panel_table <- gtable::gtable_add_rows(panel_table, max_height(axes$x$bottom), -1)
panel_table <- gtable::gtable_add_cols(panel_table, max_width(axes$y$left), 0)
panel_table <- gtable::gtable_add_cols(panel_table, max_width(axes$y$right), -1)
panel_pos_col <- panel_cols(panel_table)
panel_pos_rows <- panel_rows(panel_table)
panel_table <- gtable::gtable_add_grob(panel_table, axes$x$top, 1, panel_pos_col$l, clip = "off", name = paste0("axis-t-", seq_along(axes$x$top)), z = 3)
panel_table <- gtable::gtable_add_grob(panel_table, axes$x$bottom, -1, panel_pos_col$l, clip = "off", name = paste0("axis-b-", seq_along(axes$x$bottom)), z = 3)
panel_table <- gtable::gtable_add_grob(panel_table, axes$y$left, panel_pos_rows$t, 1, clip = "off", name = paste0("axis-l-", seq_along(axes$y$left)), z = 3)
panel_table <- gtable::gtable_add_grob(panel_table, axes$y$right, panel_pos_rows$t, -1, clip = "off", name = paste0("axis-r-", seq_along(axes$y$right)), z= 3)
# Add strips
switch_x <- !is.null(params$switch) && params$switch %in% c("both", "x")
switch_y <- !is.null(params$switch) && params$switch %in% c("both", "y")
inside_x <- (theme$strip.placement.x %||% theme$strip.placement %||% "inside") == "inside"
inside_y <- (theme$strip.placement.y %||% theme$strip.placement %||% "inside") == "inside"
strip_padding <- grid::convertUnit(theme$strip.switch.pad.grid, "cm")
panel_pos_col <- panel_cols(panel_table)
if (switch_x) {
if (!is.null(strips$x$bottom)) {
if (inside_x || all(vapply(axes$x$bottom, is.zero, logical(1)))) {
panel_table <- gtable::gtable_add_rows(panel_table, max_height(strips$x$bottom), -2)
panel_table <- gtable::gtable_add_grob(panel_table, strips$x$bottom, -2, panel_pos_col$l, clip = "on", name = paste0("strip-b-", seq_along(strips$x$bottom)), z = 2)
} else {
panel_table <- gtable::gtable_add_rows(panel_table, strip_padding, -1)
panel_table <- gtable::gtable_add_rows(panel_table, max_height(strips$x$bottom), -1)
panel_table <- gtable::gtable_add_grob(panel_table, strips$x$bottom, -1, panel_pos_col$l, clip = "on", name = paste0("strip-b-", seq_along(strips$x$bottom)), z = 2)
}
}
} else {
if (!is.null(strips$x$top)) {
if (inside_x || all(vapply(axes$x$top, is.zero, logical(1)))) {
panel_table <- gtable::gtable_add_rows(panel_table, max_height(strips$x$top), 1)
panel_table <- gtable::gtable_add_grob(panel_table, strips$x$top, 2, panel_pos_col$l, clip = "on", name = paste0("strip-t-", seq_along(strips$x$top)), z = 2)
} else {
panel_table <- gtable::gtable_add_rows(panel_table, strip_padding, 0)
panel_table <- gtable::gtable_add_rows(panel_table, max_height(strips$x$top), 0)
panel_table <- gtable::gtable_add_grob(panel_table, strips$x$top, 1, panel_pos_col$l, clip = "on", name = paste0("strip-t-", seq_along(strips$x$top)), z = 2)
}
}
}
panel_pos_rows <- panel_rows(panel_table)
if (switch_y) {
if (!is.null(strips$y$left)) {
if (inside_y || all(vapply(axes$y$left, is.zero, logical(1)))) {
panel_table <- gtable::gtable_add_cols(panel_table, max_width(strips$y$left), 1)
panel_table <- gtable::gtable_add_grob(panel_table, strips$y$left, panel_pos_rows$t, 2, clip = "on", name = paste0("strip-l-", seq_along(strips$y$left)), z = 2)
} else {
panel_table <- gtable::gtable_add_cols(panel_table, strip_padding, 0)
panel_table <- gtable::gtable_add_cols(panel_table, max_width(strips$y$left), 0)
panel_table <- gtable::gtable_add_grob(panel_table, strips$y$left, panel_pos_rows$t, 1, clip = "on", name = paste0("strip-l-", seq_along(strips$y$left)), z = 2)
}
}
} else {
if (!is.null(strips$y$right)) {
if (inside_y || all(vapply(axes$y$right, is.zero, logical(1)))) {
panel_table <- gtable::gtable_add_cols(panel_table, max_width(strips$y$right), -2)
panel_table <- gtable::gtable_add_grob(panel_table, strips$y$right, panel_pos_rows$t, -2, clip = "on", name = paste0("strip-r-", seq_along(strips$y$right)), z = 2)
} else {
panel_table <- gtable::gtable_add_cols(panel_table, strip_padding, -1)
panel_table <- gtable::gtable_add_cols(panel_table, max_width(strips$y$right), -1)
panel_table <- gtable::gtable_add_grob(panel_table, strips$y$right, panel_pos_rows$t, -1, clip = "on", name = paste0("strip-r-", seq_along(strips$y$right)), z = 2)
}
}
}
panel_table
}
)
# only change from facet_grid is the use of FacetGrid2 instead of FacetGrid
facet_grid2 <- function (rows = NULL, cols = NULL, scales = "fixed", space = "fixed",
shrink = TRUE, labeller = "label_value", as.table = TRUE,
switch = NULL, drop = TRUE, margins = FALSE, facets = lifecycle::deprecated()) {
if (lifecycle::is_present(facets)) {
deprecate_warn0("2.2.0", "facet_grid(facets)", "facet_grid(rows)")
rows <- facets
}
if (is.logical(cols)) {
margins <- cols
cols <- NULL
}
scales <- arg_match0(scales %||% "fixed", c("fixed", "free_x",
"free_y", "free"))
free <- list(x = any(scales %in% c("free_x", "free")), y = any(scales %in%
c("free_y", "free")))
space <- arg_match0(space %||% "fixed", c("fixed", "free_x",
"free_y", "free"))
space_free <- list(x = any(space %in% c("free_x", "free")),
y = any(space %in% c("free_y", "free")))
if (!is.null(switch) && !switch %in% c("both", "x", "y")) {
cli::cli_abort("{.arg switch} must be either {.val both}, {.val x}, or {.val y}")
}
facets_list <- ggplot2:::grid_as_facets_list(rows, cols)
labeller <- ggplot2:::check_labeller(labeller)
ggproto(NULL, FacetGrid2, shrink = shrink,
params = list(rows = facets_list$rows,
cols = facets_list$cols, margins = margins, free = free,
space_free = space_free, labeller = labeller, as.table = as.table,
switch = switch, drop = drop))
}
Disclaimer: I haven't tested this for other use cases because I haven't had a need for it, so... caveat emptor. :)
- Count empty strings?
- Passing an entire package to a snow cluster
- Justify multiline text in ggplot2 - title, subtitle, caption, geom_text() etc
- Using Apache Arrow or DuckDB inside a map function in R
- how to include an abstract in a rmakdown Rmd file
- Web scraping with R (Scrape Hidden Number "Click here to show number" )
- Error in kruskal_test (coin) with Weighted Data: “Invalid Object Class 'IndependenceProblem’”
- r difference in each observation within Id
- Can I create new features from a matrix?
- rmarkdown: pandoc: pdflatex not found
- ggplot2 change axis limits for each individual facet panel
- Counting observations by group using collapse R package
- construct a pseudo panel based on similar values for some variables in R
- ! LaTeX Error: Missing \begin{document}. Error: LaTeX failed to compile paper_template.tex
- Recreating a Heatmap in R
- How to set transparent plot background but fill map panel for Mollweide or Robinson projection
- BRMS: on what scale are the estimated coefficients of a model with a log link function?
- Is there a way to make the bars' colors conditional to the column?
- how to split table into 2 pages in R markdown using datasummary?
- Where can I find the default color palette used in the plotly package
- Mahalanobis distance on R for more than 2 groups
- Auto-Listing comparisons in ggbetweenstats over dates (or datetimes)
- How to make a `functools.reduce` implementation that looks similarly as `Reduce` in R?
- How to iterate object in svytable while dynamically subsetting survey design
- Plotting time intervals in R and tiling for several years
- Connect Linestrings
- Trying to add a loess smooth line to ggplot while retaining colored groupings
- Why is it wrong to use assignment inside of dplyr function R
- Why is my NMDS plot arch/horse shoe shaped?
- Removing white border plotting maps with geom_sf