Nested facets in ggplot2 spanning groups

I encountered a situation in which I want to create a plot that was facetted by three grouping variables. To do so, I would simply use facet_grid(f1 ~ f2 + f3), but the issue here is that the labels for f2 would be redundant, and it would be much better to have them span the facets for f3 nested within f2.

MWE:

library('tibble')
library('ggplot2')
df <- tribble(
  ~x, ~y, ~f1, ~f2, ~f3,
  0.5, 0.5, "a", "a", "a",
  0.5, 0.5, "b", "a", "a",
  0.5, 0.5, "a", "b", "a",
  0.5, 0.5, "b", "b", "a",
  0.5, 0.5, "a", "a", "b",
  0.5, 0.5, "b", "a", "b",
  0.5, 0.5, "a", "b", "b",
  0.5, 0.5, "b", "b", "b"
)


p <- ggplot(df, aes(x = x, y = y)) +
  geom_point() +
  facet_grid(f1 ~ f2 + f3)

Again, I'm looking to combine the labels for f2 so that they are not so redundant.

Edit: This is different from other questions in that it asks how to use the existing groupings to modify a facet as opposed to adding a new one.

The answer to this lies within the grid and gtable packages. Everything in the plot is laid out in a particular order and you can find where everything is if you dig a little.

library('gtable')
library('grid')
library('magrittr') # for the %>% that I love so well

# First get the grob
z <- ggplotGrob(p)

The ultimate goal of this operation is to overlay the top facet label, but the trick is that both of these facets exist on the same row in the grid space. They are a table within a table (look at the rows with the name "strip", also take note of the zeroGrob; these will be useful later):

z
## TableGrob (13 x 14) "layout": 34 grobs
##     z         cells       name                                   grob
## 1   0 ( 1-13, 1-14) background        rect[plot.background..rect.522]
## 2   1 ( 7- 7, 4- 4)  panel-1-1               gTree[panel-1.gTree.292]

                                    ...

## 20  3 ( 7- 7,12-12)   axis-r-1                         zeroGrob[NULL]
## 21  3 ( 9- 9,12-12)   axis-r-2                         zeroGrob[NULL]
## 22  2 ( 6- 6, 4- 4)  strip-t-1                          gtable[strip]
## 23  2 ( 6- 6, 6- 6)  strip-t-2                          gtable[strip]
## 24  2 ( 6- 6, 8- 8)  strip-t-3                          gtable[strip]
## 25  2 ( 6- 6,10-10)  strip-t-4                          gtable[strip]
## 26  2 ( 7- 7,11-11)  strip-r-1                          gtable[strip]
## 27  2 ( 9- 9,11-11)  strip-r-2                          gtable[strip]

                                    ...

## 32  8 ( 3- 3, 4-10)   subtitle  zeroGrob[plot.subtitle..zeroGrob.519]
## 33  9 ( 2- 2, 4-10)      title     zeroGrob[plot.title..zeroGrob.518]
## 34 10 (12-12, 4-10)    caption   zeroGrob[plot.caption..zeroGrob.520]

If you zoom in to the first strip, you can see the nested structure:

z$grob[[22]]
## TableGrob (2 x 1) "strip": 2 grobs
##   z     cells  name                                 grob
## 1 1 (1-1,1-1) strip absoluteGrob[strip.absoluteGrob.451]
## 2 2 (2-2,1-1) strip absoluteGrob[strip.absoluteGrob.475]

For each grob, we have an object that lists the order in which it's plotted (z), the position in the grid (cells), a label (name), and a geometry (grob).

Since we can create gtables within gtables, we are going to use this to plot over our original plot. First, we need to find the positions in the plot that need replacing.

# Find the location of the strips in the main plot
locations <- grep("strip-t", z$layout$name)

# Filter out the strips (trim = FALSE is important here for positions relative to the main plot)
strip <- gtable_filter(z, "strip-t", trim = FALSE)

# Gathering our positions for the main plot
top <- strip$layout$t[1]
l   <- strip$layout$l[c(1, 3)]
r   <- strip$layout$r[c(2, 4)]

Once we have the positions, we need to create a replacement table. We can do this with a matrix of lists (yes, it's weird. Just roll with it). This matrix needs to have three columns and two rows in our case because of the two facets and the gap between them. Since we are just going to replace data in the matrix later, we're going to create one with zeroGrobs:

mat   <- matrix(vector("list", length = 6), nrow = 2)
mat[] <- list(zeroGrob())

# The separator for the facets has zero width
res <- gtable_matrix("toprow", mat, unit(c(1, 0, 1), "null"), unit(c(1, 1), "null"))

The mask is created in two steps, covering the first facet group and then the second. In the first part, we are using the location we recorded earlier to grab the appropriate grob from the original plot and add it on top of our replacement matrix res, spanning the entire length. We then add that matrix on top of our plot.

# Adding the first layer
zz <- res %>%
  gtable_add_grob(z$grobs[[locations[1]]]$grobs[[1]], 1, 1, 1, 3) %>%
  gtable_add_grob(z, ., t = top,  l = l[1],  b = top,  r = r[1], name = c("add-strip"))

# Adding the second layer (note the indices)
pp <- gtable_add_grob(res, z$grobs[[locations[3]]]$grobs[[1]], 1, 1, 1, 3) %>%
  gtable_add_grob(zz, ., t = top,  l = l[2],  b = top,  r = r[2], name = c("add-strip"))

# Plotting
grid.newpage()
print(grid.draw(pp))