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. :)
- grid.arrange's relative height argument didn't works well in RMarkdown
- How apply a function to every element of a matrix?
- Polar plot in R using ggplot2
- Find total length of time in multiple values of a dataset that overlaps with a given period of time
- Faster than R's `simplify2array`?
- What is the most simple way to label a data.table frequency chart in R?
- How to show dates in a secondary x-axis while the primary x-axis is numerical?
- online compiler for r-markdown document
- Unecessarily large column widths in HTML tables published by R Quarto when the table header contains special characters
- Bootstrapping a vector of results, by group in R
- Speeding Up Monte Carlo Simulations for Weather-Dependent Claims
- Is there an R class which allows to list 2 elements but shows only the first of them by default when called?
- Convert day of week number to weekday name in R
- How do you use "<<-" (scoping assignment) in R?
- Using reactivePoll to monitor and process file changes
- How to find out which graph is most similar to another graph?
- ggplot2: rectangular background behind axis text in circular bar plot
- How to simulate button click using rvest
- CMIP6, automating by month
- Covert dummy variables to single categorical in R?
- Animated reducing bar chart with gganimate
- Create an object class matrix/array from data frame
- How to add a vector of names to `sort_by()` in base R
- Among many subfolders, find CSVs starting with a given string and within ZIPs or not, and merge them while adding their names in a new column with R
- How to add a greek letter to an axis label to a 3D plot in plotly?
- bigrquery + dplyr error when using functions and sourcing from separate R script
- Shiny App Error: /v1/applications/ 400 - Validation Error Execution halted
- Rupee Unicode replacement not working in R
- Mutate multiple variable to create multiple new variables
- How to use the Stata equivalent of a foreach loop in R with mutate()