CODEWITHSUNDEEP
rggplot2facetclipping
r2evans
r2evans

Reputation: 161007

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")

ggplot2 with per-facet limits

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")

ggplot2 with side labels and broken clipping

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?

Upvotes: 2

Views: 262

Answers (2)

Z.Lin
Z.Lin

Reputation: 29125

(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")

result

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")

result2

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

Upvotes: 1

stefan
stefan

Reputation: 125727

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)
    )
  )

enter image description here

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)
    )
  )

enter image description here

Upvotes: 1

Related Questions