ggtern - distorted hex bin size and shape when faceted

I have an issue where geom_hex_tern works perfectly with single plots but the hex bin size and shape gets distorted when I make facets.

library(tidyverse)
library(ggtern)

# My data
dat <- structure(list(Fact2 = c(0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 
  0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 
  0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 
  0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 
  0.24, 0.28, 0.28, 0.28, 0.28, 0.28), x = c(0.05, 0.1, 0.1, 0.1, 
    0.15, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.25, 0.25, 0.25, 0.25, 
    0.3, 0.3, 0.35, 0.35, 0.4, 0.4, 0.4, 0.45, 0.45, 0.45, 0.45, 
    0.5, 0.5, 0.5, 0.5, 0.55, 0.55, 0.55, 0.6, 0.6, 0.6, 0.65, 0.7, 
    0.75, 0.05, 0.1, 0.2, 0.3, 0.45), y = c(0.6, 0.5, 0.6, 0.7, 0.55, 
      0.1, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.35, 0.4, 0.45, 0.5, 0.3, 
      0.4, 0.25, 0.4, 0.3, 0.35, 0.4, 0.2, 0.25, 0.35, 0.45, 0.05, 
      0.15, 0.2, 0.25, 0.1, 0.2, 0.3, 0.05, 0.1, 0.25, 0.1, 0.05, 0.05, 
      0.55, 0.5, 0.55, 0.2, 0.25), z = c(0.35, 0.4, 0.3, 0.2, 0.3, 
        0.7, 0.45, 0.4, 0.35, 0.3, 0.25, 0.2, 0.4, 0.35, 0.3, 0.25, 0.4, 
        0.3, 0.4, 0.25, 0.3, 0.25, 0.2, 0.35, 0.3, 0.2, 0.1, 0.45, 0.35, 
        0.3, 0.25, 0.35, 0.25, 0.15, 0.35, 0.3, 0.15, 0.25, 0.25, 0.2, 
        0.4, 0.4, 0.25, 0.5, 0.3), wt = c(0.027, 0.02, 0.016, 0.017, 
          0.043, 0.018, 0.02, 0.023, 0.037, 0.02, 0.018, 0.02, 0.015, 0.043, 
          0.031, 0.033, 0.036, 0.029, 0.015, 0.022, 0.036, 0.022, 0.017, 
          0.02, 0.022, 0.018, 0.019, 0.023, 0.02, 0.065, 0.038, 0.043, 
          0.02, 0.023, 0.063, 0.02, 0.018, 0.025, 0.042, 0.016, 0.015, 
          0.019, 0.017, 0.018, 0.039)), row.names = c(NA, -45L), class = c("tbl_df", 
            "tbl", "data.frame"))


# PLot Fact2 == 0.24 - OK
filter(dat, Fact2 == 0.24) %>%
  ggtern(aes(x = x, y = y, z = z)) + 
  geom_hex_tern(binwidth = 0.05, colour = "black",  aes(value = wt)) 

# PLot Fact2 == 0.28 - OK
filter(dat, Fact2 == 0.28) %>%
ggtern(aes(x = x, y = y, z = z)) + 
  geom_hex_tern(binwidth = 0.05, colour = "black", aes(value = wt)) 

# plot both together - weird hex bin size/shape 
ggtern(dat, aes(x = x, y = y, z = z)) + 
  geom_hex_tern(binwidth = 0.05, colour = "black", aes(value = wt)) +
  facet_wrap(~Fact2) 

The first two plots look good, but the bins are messed up when plotted together via faceting, this only seems to happen when I plot sparse data (few bins) faceting works fine when I have lots of points on each plot. Any advice how I can get the faceted plots looking normal would be much appreciated.

I have a working solution, though I can't help thinking I've done it the hard way.

Initially, since you pointed out that the problem goes away when there are lots of bins to be plotted, I experimented with trying to draw lots of extra invisible hexagons with an added dummy variable which controlled the alpha (transparency). Unfortunately, this doesn't work when you are using binned data.

I also tried creating invisible hexagons in a different layer. This is possible, but having the invisible hexagons in a different layer means they no longer coerce the hexagons in the visible layer to the correct shape.

The other thought that occurred was to try a 2 x 2 facet, as I assumed this would normalize the hexagons' shapes. It doesn't.

In the end I decided to just "crack open" the ggplot, get the hex grobs and change their vertices arithmetically. The mathematical stretching itself is straightforward, since the hex grobs are already centred correctly and are exactly half their desired height; we therefore just take the y co-ordinates and subtract the mean of their range from double their value.

The tricky part is getting the grobs in the first place. First you need to convert the ggplot to a table of grobs (ggtern has its own functions to do this). This is simple enough, but the gTable is a deeply nested S3 object, so finding a general solution to the problem of extracting the correct elements was tricky. Putting them back in place in the correct format was complex, requiring nested mapply functions.

However, now that this is done, the logic can all be contained within a function that takes only the ggplot as input and then plots the version with stretched hex grobs (while also returning a gTable silently in case you want to do anything else with it)

fix_hexes <- function(plot_object)
{
  # Define all the helper functions used in the mapply and lapply calls
  cmapply     <-  function(...)    mapply(..., SIMPLIFY = FALSE)
  get_hexes   <-  function(x)      x$children[grep("hex", names(x$children))]
  write_kids  <-  function(x, y) { x[[1]]$children <- y; return(x)}
  write_y     <-  function(x, y) { x$y <- y; return(x)}
  write_all_y <-  function(x, y) { gList <- mapply(write_y, x, y, SIMPLIFY = F)
                                   class(gList) <- "gList"; return(gList) }
  write_hex   <-  function(x, y) { x$children[grep("hex", names(x$children))] <- y; x; }
  fix_each    <-  function(y) {    yval <- y$y
                                   att  <- attributes(yval)
                                   yval <- as.numeric(yval)
                                   yval <- 2 * yval - mean(range(yval))
                                   att  -> attributes(yval)
                                   return(yval)}

  # Extract and fix the grobs
  g_table     <- ggtern::ggplot_gtable(ggtern::ggplot_build(plot_object))
  panels      <- which(sapply(g_table$grobs, function(x) length(names(x)) == 5))
  hexgrobs    <- lapply(g_table$grobs[panels], get_hexes)
  all_hexes   <- lapply(hexgrobs, function(x) x[[1]]$children)
  fixed_yvals <- lapply(all_hexes, lapply, fix_each)

  # Reinsert the fixed grobs
  fixed_hexes            <- cmapply(write_all_y, all_hexes, fixed_yvals)
  fixed_grobs            <- cmapply(write_kids, hexgrobs, fixed_hexes)  
  g_table$grobs[panels]  <- cmapply(write_hex, g_table$grobs[panels], fixed_grobs)

  # Draw the plot on a fresh page and silently return the gTable
  grid::grid.newpage()
  grid::grid.draw(g_table)
  invisible(g_table)
}

So let's see the original plot:

gg <- ggtern(dat, aes(x = x, y = y, z = z)) + 
       geom_hex_tern(binwidth = 0.05, colour = "black", aes(value = wt)) +
       facet_wrap(~Fact2)

plot(gg)

And we can fix it now by simply doing:

fix_hexes(gg)