Skip to content

Instantly share code, notes, and snippets.

@burchill

burchill/facet_setter.R

Last active Aug 26, 2020
Embed
What would you like to do?
Set coordinates for individual ggplot2 facets
if (packageVersion("ggplot2") < "3.1.0") {
stop("Need to use new version of ggplot!")
} else {
library(ggplot2)
}
UniquePanelCoords <- ggplot2::ggproto(
"UniquePanelCoords", ggplot2::CoordCartesian,
num_of_panels = 1,
panel_counter = 1,
panel_ranges = NULL,
setup_layout = function(self, layout, params) {
self$num_of_panels <- length(unique(layout$PANEL))
self$panel_counter <- 1
layout
},
setup_panel_params = function(self, scale_x, scale_y, params = list()) {
if (!is.null(self$panel_ranges) & length(self$panel_ranges) != self$num_of_panels)
stop("Number of panel ranges does not equal the number supplied")
train_cartesian <- function(scale, limits, name, given_range = NULL) {
if (is.null(given_range))
range <- ggplot2:::scale_range(scale, limits, self$expand)
else
range <- given_range
out <- scale$break_info(range)
out$arrange <- scale$axis_order()
names(out) <- paste(name, names(out), sep = ".")
out
}
cur_panel_ranges <- self$panel_ranges[[self$panel_counter]]
if (self$panel_counter < self$num_of_panels)
self$panel_counter <- self$panel_counter + 1
else
self$panel_counter <- 1
c(train_cartesian(scale_x, self$limits$x, "x", cur_panel_ranges$x),
train_cartesian(scale_y, self$limits$y, "y", cur_panel_ranges$y))
}
)
coord_panel_ranges <- function(panel_ranges, expand = TRUE, default = FALSE, clip = "on")
{
ggplot2::ggproto(NULL, UniquePanelCoords, panel_ranges = panel_ranges,
expand = expand, default = default, clip = clip)
}
################### Examples ###########################################################################
test_data <- structure(list(DataType = structure(c(1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), .Label = c("A", "B"), class = "factor"),
ExpType = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), .Label = c("X", "Y"), class = "factor"),
EffectSize = structure(c(1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L,
1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 2L, 2L, 2L,
2L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L), .Label = c("15", "35"
), class = "factor"), Nsubjects = c(8, 16, 32, 64, 8, 16,
32, 64, 8, 16, 32, 64, 8, 16, 32, 64, 8, 16, 32, 64, 8, 16,
32, 64, 8, 16, 32, 64, 8, 16, 32, 64), Odds = c(1.06248116259846,
1.09482076720863, 1.23086993413208, 1.76749340505612, 1.06641831731573,
1.12616954196688, 1.48351814320987, 3.50755080416964, 1.11601399761081,
1.18352602009495, 1.45705466646283, 2.53384744810515, 1.13847061762186,
1.24983742407086, 1.97075900741022, 6.01497152563726, 1.02798821372378,
1.06297006279249, 1.19432835697453, 1.7320754674107, 1.02813271730924,
1.09355953747203, 1.44830680332583, 3.4732692664923, 1.06295915758305,
1.12008443626365, 1.3887632112682, 2.46321037334, 1.06722652223114,
1.1874936754725, 1.89870184372054, 5.943747409114), Upper = c(1.72895843644471,
2.09878774769559, 2.59771794965346, 5.08513435549015, 1.72999898901071,
1.8702196882561, 3.85385388850167, 5.92564404180303, 1.99113042576373,
2.61074135841984, 3.45852331828636, 4.83900142207583, 1.57897154221764,
1.8957409107653, 10, 75, 2.3763918424135, 2.50181951057562,
3.45037180395673, 3.99515276392065, 2.04584535265976, 2.39317394040066,
2.832526733659, 5.38414183471915, 1.40569501856836, 2.6778044191832,
2.98023068052396, 4.75934650422069, 1.54116883311054, 2.50647989271592,
3.48517589981551, 100), Lower = c(0.396003888752214, 0.0908537867216577,
-0.135978081389309, -1.55014754537791, 0.40283764562075,
0.382119395677663, -0.88681760208193, 1.08945756653624, 0.240897569457892,
-0.243689318229938, -0.544413985360706, 0.228693474134466,
0.69796969302609, 0.603933937376415, 0.183548809738402, 3.57236968943798,
-0.320415414965949, -0.375879384990643, -1.06171509000767,
-0.531001829099242, 0.010420081958713, -0.206054865456611,
0.0640868729926525, 1.56239669826544, 0.720223296597732,
-0.437635546655903, -0.202704257987574, 0.167074242459314,
0.593284211351745, -0.131492541770921, 0.312227787625573,
3.76692741957876)), .Names = c("DataType", "ExpType", "EffectSize",
"Nsubjects", "Odds", "Upper", "Lower"), class = c("tbl_df", "tbl",
"data.frame"), row.names = c(NA, -32L))
# Bad plot:
test_data %>%
ggplot(aes(x=Nsubjects, y = Odds, color=EffectSize)) +
facet_wrap(DataType ~ ExpType, labeller = label_both, scales="free") +
geom_line(size=2) +
geom_ribbon(aes(ymax=Upper, ymin=Lower, fill=EffectSize, color=NULL), alpha=0.2)
# Better plot
test_data %>%
ggplot(aes(x=Nsubjects, y = Odds, color=EffectSize)) +
facet_wrap(DataType ~ ExpType, labeller = label_both, scales="free") +
geom_line(size=2) +
geom_ribbon(aes(ymax=Upper, ymin=Lower, fill=EffectSize, color=NULL), alpha=0.2) +
coord_panel_ranges(panel_ranges = list(
list(x=c(8,64), y=c(1,4)), # Panel 1
list(x=c(8,64), y=c(1,6)), # Panel 2
list(NULL), # Panel 3, an empty list falls back on the default values
list(x=c(8,64), y=c(1,7)) # Panel 4
))
@r2evans

This comment has been minimized.

Copy link

@r2evans r2evans commented Aug 11, 2020

@burchill, any chance you've had reason to update this with ggplot2 since they removed scale_range in tidyverse/ggplot2@7f317d4? I've been able to get a little into it, with

      train_cartesian <- function(scale, limits, name, given_range = NULL) {
        if (is.null(given_range)) {
-         range <- scale_range(scale, limits, self$expand)
+         expansion <- ggplot2:::default_expansion(scale, expand = self$expand)
+         range <- ggplot2:::expand_limits_scale(scale, expansion,
+                                                coord_limits = self$limits[[name]])
        } else {
          range <- given_range
        }
        
        out <- scale$break_info(range)
        out$arrange <- scale$axis_order()
        names(out) <- paste(name, names(out), sep = ".")
        out
      }

(I'm not certain that's perfect, but it does produce the same output as the old scale_range used to return.)

But I'm falling flat on my face with:

test_data %>%
  ggplot(aes(x=Nsubjects, y = Odds, color=EffectSize)) +
  facet_wrap(DataType ~ ExpType, labeller = label_both, scales="free") +
  geom_line(size=2) +
  geom_ribbon(aes(ymax=Upper, ymin=Lower, fill=EffectSize, color=NULL), alpha=0.2) +
  coord_panel_ranges(panel_ranges = list(
    list(x=c(8,64), y=c(1,4)), # Panel 1
    list(x=c(8,64), y=c(1,6)), # Panel 2
    list(NULL),                # Panel 3, an empty list falls back on the default values
    list(x=c(8,64), y=c(1,7))  # Panel 4
  ))
# Error in panel_params$x$break_positions_minor() : 
#   attempt to apply non-function
#      x
#   1. +-(function (x, ...) ...
#   2. \-ggplot2:::print.ggplot(x)
#   3.   +-ggplot2::ggplot_gtable(data)
#   4.   \-ggplot2:::ggplot_gtable.ggplot_built(data)
#   5.     \-layout$render(geom_grobs, data, theme, plot$labels)
#   6.       \-ggplot2:::f(..., self = self)
#   7.         \-base::lapply(...)
#   8.           \-ggplot2:::FUN(X[[i]], ...)
#   9.             \-self$coord$render_bg(self$panel_params[[i]], theme)
#  10.               \-ggplot2:::f(...)
#  11.                 \-ggplot2:::guide_grid(...)
#  12.                   \-base::setdiff(x.minor, x.major)
#  13.                     \-base::as.vector(x)
@r2evans

This comment has been minimized.

Copy link

@r2evans r2evans commented Aug 24, 2020

@burchill, I think I have figured out a way ahead.

I adapted (heavily) your code into https://gist.github.com/r2evans/6057f7995c117bb787495dc14a228d5d, which implements coord_cartesian_panels. Besides the function name itself, it now uses a data frame with facet variables and min/max columns to match against the faceted variables, enabling each of the following:

p <- test_data %>%
  ggplot(aes(x=Nsubjects, y = Odds, color=EffectSize)) +
  facet_wrap(DataType ~ ExpType, labeller = label_both, scales="free") +
  geom_line(size=2) +
  geom_ribbon(aes(ymax=Upper, ymin=Lower, fill=EffectSize, color=NULL), alpha=0.2)

# a replica of your plot
p + coord_cartesian_panels(
  panel_limits = tibble::tribble(
    ~DataType, ~ExpType, ~ymin, ~ymax
  , "A"      , "X"     ,     1,     4
  , "A"      , "Y"     ,     1,     6
  , "B"      , "Y"     ,     1,     7
  )
)

# extension, subset of facet variables
p + coord_cartesian_panels(
  panel_limits = tibble::tribble(
    ~ExpType, ~ymin, ~ymax
  , "X"     ,    NA,     4
  , "Y"     ,     1,     5
  )
)

This was enabled by some help on my stackoverflow question.

@burchill

This comment has been minimized.

Copy link
Owner Author

@burchill burchill commented Aug 25, 2020

Thanks, @r2evans! Sorry about the radio silence, I just started a job while working on my dissertation, so I've been swamped.
That looks absolutely awesome!

My one possible recommendation (take this how you will, based on your preferences of coding style) might be doing something like this:

coord_cartesian_panels <- function(..., panel_limits = NULL, 
                                   expand = TRUE, default = FALSE, clip = "on") {
  if (is.null(panel_limits))   panel_limits <- tribble::tribble(...)
  ggplot2::ggproto(NULL, UniquePanelCoords,
                   panel_limits = panel_limits,
                   expand = expand, default = default, clip = clip)
}
# You could then do:
p + coord_cartesian_panels(
  ~ExpType, ~ymin, ~ymax
  , "X"     ,    NA,     4
  , "Y"     ,     1,     5
)

This should let your users save a little typing (by letting them use the tribble input system automatically), while still giving them the option of using the longer, more flexible input system (via panel_limits argument) if they want.

@r2evans

This comment has been minimized.

Copy link

@r2evans r2evans commented Aug 25, 2020

That's an appealing feature! I have used polymorphic functions with similar ... functionality, my only concern is consistency with the rest of the ggplot2 dialect.

FYI, I've been chatting some with teunbrand, author of https://github.com/teunbrand/ggh4x, which does something similar but falls into the same trap of using panel-order in a list. I know it's not evil, but I really really prefer to be able to not care about order (and holes), since my use-cases tend to be programmatic both in the number and, at times, order of panels. Granted, since my code changes the order, one would think that I can control that, but ... anyway, you know what I mean.

I might fork and contribute to teunbrand's project, because I really like ability to arbitrarily add scale_* per panel.

Again, thanks for the impetus, and good luck with the new job and your dissertation.

@r2evans

This comment has been minimized.

Copy link

@r2evans r2evans commented Aug 26, 2020

FYI, I troubleshot some stupid typos of my own and then found one in yours: tribble::tribble --> tibble::tribble.

Thanks, I do like that extension. (I incorporated it into my gist.)

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment