control per-axis ggplot2 clipping

Question

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:

1. 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.

2. Find a way to clip on the y axis and not the x. 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.

3. Incorporate oob use (e.g., scales::oob_squish) into the ggproto use within coord_cartesian_panels.

4. Something else?

Innocency

Answer 1

(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. :)

Nylanylghau

Your point about using cowplot/patchwork for combining the labels is a novel approach; I've had really good success in the past with patchwork on more traditional things, I had not considered combining more complex faceted plots. That's a good idea as well! – Innocency

Your use of clip = c("on", "off", "on") is a little confusing: if these are to be assigned to the respective panels (order matters), then I would expect at least one of the plots to have a clipping problem. The only way that makes sense in my head is if the "off" corresponds to z == 1, but I don't see how that would be inferred based on the order of factors. Can you explain how length-2 in your first code block and length-3 in your second is intended to work? – Innocency

The multiple clip = c(..) is for different geom layers, not facet panels, so in this case clipping is on for the geom_line & 2nd geom_label layers, but off for the 1st geom_label layer. Values for z don't come into it. – Nylanylghau

ahhh, I misread your explanation before, thank you for clarifying! – Innocency

Answer 2

Adapting my answer on this post one option which does not require to disable clipping would be to use the secondary axis trick to add your labels via a duplicated axis. To set the breaks and labels individually per facet I draw on ggh4x::facetted_pos_scales and use ggtext::element_markdown for the geom_label look:

library(ggplot2)
library(ggh4x)
library(ggtext)

scale_dup <- function(x) {
  scale_y_continuous(
    sec.axis = dup_axis(
      breaks = summ[summ$z == x, "y", drop = TRUE],
      labels = summ[summ$z == x, "lbl", drop = TRUE]
    )
  )
}

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") +
  theme(
    axis.ticks.y.right = element_blank(),
    axis.text.y.right = ggtext::element_markdown(
      size = 12,
      linewidth = .25,
      linetype = 1,
      r = unit(.25, "lines"),
      padding = unit(2, "pt")
    )
  ) +
  facetted_pos_scales(
    y = list(
      z == "1" ~ scale_dup(1),
      z == "2" ~ scale_dup(2),
      z == "3" ~ scale_dup(3)
    )
  )

EDIT Using the updated summ dataset, multiple labels are easily achieved. But unfortunately ggtext does not support the CSS property background-color so having different fill colors is not that easy to achieve. Of course could we pass a vector of colors to the fill= argument of element_markdown but that will only for work for some limited cases, i.e. we can't set the fill color individually for each panel.

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") +
  theme(
    axis.ticks.y.right = element_blank(),
    axis.text.y.right = ggtext::element_markdown(
      size = 12,
      linewidth = .25,
      linetype = 1,
      r = unit(.25, "lines"),
      padding = unit(2, "pt"),
      fill = scales::hue_pal()(2)
    )
  ) +
  facetted_pos_scales(
    y = list(
      z == "1" ~ scale_dup(1),
      z == "2" ~ scale_dup(2),
      z == "3" ~ scale_dup(3)
    )
  )

Betti

This is a very interesting direction, thank you stefan! As always, there's just a little bit more: the right-side labels have background colors (fill= works), and there are multiple labels per facet, and each has its own color. I'll adapt the question to better reflect this. Since the order of colors in the labels is variable, I don't know if element_markdown will easily support it. – Innocency

I edited my question to depict what I was talking about. I'm really intrigued by the use of ggh4x/ggtext here, a very promising direction. Thank you again! – Innocency

Multiple labels are easily achieved. But you are right, while text colors are easily achieved, ggtext does not support the CSS property background-color. What a shame. :D Of course could we pass a vector of colors to the fill argument of element_markdown but that throws a bunch of warnings. :) – Betti

For completeness I just made an edit to account for multiple labels and limited support of fill colors. (: – Betti

I really appreciate the elegance of your approach @stefan, but unfortunately the background color (I should have stated in the first draft of the question) is a hard requirement (by the client). In fact, I prefer this to what we're currently doing, as it seems more ggplot2-canonical, but the bg-fill is a hard requirement. Thank you for the effort! – Innocency

I really appreciate this novel approach! Alas, I can only accept one ... – Innocency