1#' @include ggproto.r 2NULL 3 4#' @section Facets: 5#' 6#' All `facet_*` functions returns a `Facet` object or an object of a 7#' `Facet` subclass. This object describes how to assign data to different 8#' panels, how to apply positional scales and how to lay out the panels, once 9#' rendered. 10#' 11#' Extending facets can range from the simple modifications of current facets, 12#' to very laborious rewrites with a lot of [gtable()] manipulation. 13#' For some examples of both, please see the extension vignette. 14#' 15#' `Facet` subclasses, like other extendible ggproto classes, have a range 16#' of methods that can be modified. Some of these are required for all new 17#' subclasses, while other only need to be modified if need arises. 18#' 19#' The required methods are: 20#' 21#' - `compute_layout`: Based on layer data compute a mapping between 22#' panels, axes, and potentially other parameters such as faceting variable 23#' level etc. This method must return a data.frame containing at least the 24#' columns `PANEL`, `SCALE_X`, and `SCALE_Y` each containing 25#' integer keys mapping a PANEL to which axes it should use. In addition the 26#' data.frame can contain whatever other information is necessary to assign 27#' observations to the correct panel as well as determining the position of 28#' the panel. 29#' 30#' - `map_data`: This method is supplied the data for each layer in 31#' turn and is expected to supply a `PANEL` column mapping each row to a 32#' panel defined in the layout. Additionally this method can also add or 33#' subtract data points as needed e.g. in the case of adding margins to 34#' `facet_grid()`. 35#' 36#' - `draw_panels`: This is where the panels are assembled into a 37#' `gtable` object. The method receives, among others, a list of grobs 38#' defining the content of each panel as generated by the Geoms and Coord 39#' objects. The responsibility of the method is to decorate the panels with 40#' axes and strips as needed, as well as position them relative to each other 41#' in a gtable. For some of the automatic functions to work correctly, each 42#' panel, axis, and strip grob name must be prefixed with "panel", "axis", and 43#' "strip" respectively. 44#' 45#' In addition to the methods described above, it is also possible to override 46#' the default behaviour of one or more of the following methods: 47#' 48#' - `setup_params`: 49#' - `init_scales`: Given a master scale for x and y, create panel 50#' specific scales for each panel defined in the layout. The default is to 51#' simply clone the master scale. 52#' 53#' - `train_scales`: Based on layer data train each set of panel 54#' scales. The default is to train it on the data related to the panel. 55#' 56#' - `finish_data`: Make last-minute modifications to layer data 57#' before it is rendered by the Geoms. The default is to not modify it. 58#' 59#' - `draw_back`: Add a grob in between the background defined by the 60#' Coord object (usually the axis grid) and the layer stack. The default is to 61#' return an empty grob for each panel. 62#' 63#' - `draw_front`: As above except the returned grob is placed 64#' between the layer stack and the foreground defined by the Coord object 65#' (usually empty). The default is, as above, to return an empty grob. 66#' 67#' - `draw_labels`: Given the gtable returned by `draw_panels`, 68#' add axis titles to the gtable. The default is to add one title at each side 69#' depending on the position and existence of axes. 70#' 71#' All extension methods receive the content of the params field as the params 72#' argument, so the constructor function will generally put all relevant 73#' information into this field. The only exception is the `shrink` 74#' parameter which is used to determine if scales are retrained after Stat 75#' transformations has been applied. 76#' 77#' @rdname ggplot2-ggproto 78#' @format NULL 79#' @usage NULL 80#' @export 81Facet <- ggproto("Facet", NULL, 82 shrink = FALSE, 83 params = list(), 84 85 compute_layout = function(data, params) { 86 abort("Not implemented") 87 }, 88 map_data = function(data, layout, params) { 89 abort("Not implemented") 90 }, 91 init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) { 92 scales <- list() 93 if (!is.null(x_scale)) { 94 scales$x <- lapply(seq_len(max(layout$SCALE_X)), function(i) x_scale$clone()) 95 } 96 if (!is.null(y_scale)) { 97 scales$y <- lapply(seq_len(max(layout$SCALE_Y)), function(i) y_scale$clone()) 98 } 99 scales 100 }, 101 train_scales = function(x_scales, y_scales, layout, data, params) { 102 # loop over each layer, training x and y scales in turn 103 for (layer_data in data) { 104 match_id <- match(layer_data$PANEL, layout$PANEL) 105 106 if (!is.null(x_scales)) { 107 x_vars <- intersect(x_scales[[1]]$aesthetics, names(layer_data)) 108 SCALE_X <- layout$SCALE_X[match_id] 109 110 scale_apply(layer_data, x_vars, "train", SCALE_X, x_scales) 111 } 112 113 if (!is.null(y_scales)) { 114 y_vars <- intersect(y_scales[[1]]$aesthetics, names(layer_data)) 115 SCALE_Y <- layout$SCALE_Y[match_id] 116 117 scale_apply(layer_data, y_vars, "train", SCALE_Y, y_scales) 118 } 119 } 120 }, 121 draw_back = function(data, layout, x_scales, y_scales, theme, params) { 122 rep(list(zeroGrob()), length(unique(layout$PANEL))) 123 }, 124 draw_front = function(data, layout, x_scales, y_scales, theme, params) { 125 rep(list(zeroGrob()), length(unique(layout$PANEL))) 126 }, 127 draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { 128 abort("Not implemented") 129 }, 130 draw_labels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, labels, params) { 131 panel_dim <- find_panel(panels) 132 133 xlab_height_top <- grobHeight(labels$x[[1]]) 134 panels <- gtable_add_rows(panels, xlab_height_top, pos = 0) 135 panels <- gtable_add_grob(panels, labels$x[[1]], name = "xlab-t", 136 l = panel_dim$l, r = panel_dim$r, t = 1, clip = "off") 137 138 xlab_height_bottom <- grobHeight(labels$x[[2]]) 139 panels <- gtable_add_rows(panels, xlab_height_bottom, pos = -1) 140 panels <- gtable_add_grob(panels, labels$x[[2]], name = "xlab-b", 141 l = panel_dim$l, r = panel_dim$r, t = -1, clip = "off") 142 143 panel_dim <- find_panel(panels) 144 145 ylab_width_left <- grobWidth(labels$y[[1]]) 146 panels <- gtable_add_cols(panels, ylab_width_left, pos = 0) 147 panels <- gtable_add_grob(panels, labels$y[[1]], name = "ylab-l", 148 l = 1, b = panel_dim$b, t = panel_dim$t, clip = "off") 149 150 ylab_width_right <- grobWidth(labels$y[[2]]) 151 panels <- gtable_add_cols(panels, ylab_width_right, pos = -1) 152 panels <- gtable_add_grob(panels, labels$y[[2]], name = "ylab-r", 153 l = -1, b = panel_dim$b, t = panel_dim$t, clip = "off") 154 155 panels 156 }, 157 setup_params = function(data, params) { 158 params$.possible_columns <- unique(unlist(lapply(data, names))) 159 params 160 }, 161 setup_data = function(data, params) { 162 data 163 }, 164 finish_data = function(data, layout, x_scales, y_scales, params) { 165 data 166 }, 167 vars = function() { 168 character(0) 169 } 170) 171 172# Helpers ----------------------------------------------------------------- 173 174#' Quote faceting variables 175#' 176#' @description 177#' Just like [aes()], `vars()` is a [quoting function][rlang::quotation] 178#' that takes inputs to be evaluated in the context of a dataset. 179#' These inputs can be: 180#' 181#' * variable names 182#' * complex expressions 183#' 184#' In both cases, the results (the vectors that the variable 185#' represents or the results of the expressions) are used to form 186#' faceting groups. 187#' 188#' @param ... Variables or expressions automatically quoted. These are 189#' evaluated in the context of the data to form faceting groups. Can 190#' be named (the names are passed to a [labeller][labellers]). 191#' 192#' @seealso [aes()], [facet_wrap()], [facet_grid()] 193#' @export 194#' @examples 195#' p <- ggplot(mtcars, aes(wt, disp)) + geom_point() 196#' p + facet_wrap(vars(vs, am)) 197#' 198#' # vars() makes it easy to pass variables from wrapper functions: 199#' wrap_by <- function(...) { 200#' facet_wrap(vars(...), labeller = label_both) 201#' } 202#' p + wrap_by(vs) 203#' p + wrap_by(vs, am) 204#' 205#' # You can also supply expressions to vars(). In this case it's often a 206#' # good idea to supply a name as well: 207#' p + wrap_by(drat = cut_number(drat, 3)) 208#' 209#' # Let's create another function for cutting and wrapping a 210#' # variable. This time it will take a named argument instead of dots, 211#' # so we'll have to use the "enquote and unquote" pattern: 212#' wrap_cut <- function(var, n = 3) { 213#' # Let's enquote the named argument `var` to make it auto-quoting: 214#' var <- enquo(var) 215#' 216#' # `as_label()` will create a nice default name: 217#' nm <- as_label(var) 218#' 219#' # Now let's unquote everything at the right place. Note that we also 220#' # unquote `n` just in case the data frame has a column named 221#' # `n`. The latter would have precedence over our local variable 222#' # because the data is always masking the environment. 223#' wrap_by(!!nm := cut_number(!!var, !!n)) 224#' } 225#' 226#' # Thanks to tidy eval idioms we now have another useful wrapper: 227#' p + wrap_cut(drat) 228vars <- function(...) { 229 quos(...) 230} 231 232 233#' Is this object a faceting specification? 234#' 235#' @param x object to test 236#' @keywords internal 237#' @export 238is.facet <- function(x) inherits(x, "Facet") 239 240# A "special" value, currently not used but could be used to determine 241# if faceting is active 242NO_PANEL <- -1L 243 244unique_combs <- function(df) { 245 if (length(df) == 0) return() 246 247 unique_values <- lapply(df, ulevels) 248 rev(expand.grid(rev(unique_values), stringsAsFactors = FALSE, 249 KEEP.OUT.ATTRS = TRUE)) 250} 251 252df.grid <- function(a, b) { 253 if (is.null(a) || nrow(a) == 0) return(b) 254 if (is.null(b) || nrow(b) == 0) return(a) 255 256 indexes <- expand.grid( 257 i_a = seq_len(nrow(a)), 258 i_b = seq_len(nrow(b)) 259 ) 260 unrowname(cbind( 261 a[indexes$i_a, , drop = FALSE], 262 b[indexes$i_b, , drop = FALSE] 263 )) 264} 265 266# A facets spec is a list of facets. A grid facetting needs two facets 267# while a wrap facetting flattens all dimensions and thus accepts any 268# number of facets. 269# 270# A facets is a list of grouping variables. They are typically 271# supplied as variable names but can be expressions. 272# 273# as_facets() is complex due to historical baggage but its main 274# purpose is to create a facets spec from a formula: a + b ~ c + d 275# creates a facets list with two components, each of which bundles two 276# facetting variables. 277 278as_facets_list <- function(x) { 279 x <- validate_facets(x) 280 if (is_quosures(x)) { 281 x <- quos_auto_name(x) 282 return(list(x)) 283 } 284 285 # This needs to happen early because we might get a formula. 286 # facet_grid() directly converted strings to a formula while 287 # facet_wrap() called as.quoted(). Hence this is a little more 288 # complicated for backward compatibility. 289 if (is_string(x)) { 290 x <- parse_expr(x) 291 } 292 293 # At this level formulas are coerced to lists of lists for backward 294 # compatibility with facet_grid(). The LHS and RHS are treated as 295 # distinct facet dimensions and `+` defines multiple facet variables 296 # inside each dimension. 297 if (is_formula(x)) { 298 return(f_as_facets_list(x)) 299 } 300 301 # For backward-compatibility with facet_wrap() 302 if (!is_bare_list(x)) { 303 x <- as_quoted(x) 304 } 305 306 # If we have a list there are two possibilities. We may already have 307 # a proper facet spec structure. Otherwise we coerce each element 308 # with as_quoted() for backward compatibility with facet_grid(). 309 if (is.list(x)) { 310 x <- lapply(x, as_facets) 311 } 312 313 x 314} 315 316validate_facets <- function(x) { 317 if (inherits(x, "uneval")) { 318 abort("Please use `vars()` to supply facet variables") 319 } 320 if (inherits(x, "ggplot")) { 321 abort( 322 "Please use `vars()` to supply facet variables\nDid you use %>% instead of +?" 323 ) 324 } 325 x 326} 327 328 329# Flatten a list of quosures objects to a quosures object, and compact it 330compact_facets <- function(x) { 331 x <- flatten_if(x, is_list) 332 null_or_missing <- vapply(x, function(x) quo_is_null(x) || quo_is_missing(x), logical(1)) 333 new_quosures(x[!null_or_missing]) 334} 335 336# Compatibility with plyr::as.quoted() 337as_quoted <- function(x) { 338 if (is.character(x)) { 339 if (length(x) > 1) { 340 x <- paste(x, collapse = "; ") 341 } 342 return(parse_exprs(x)) 343 } 344 if (is.null(x)) { 345 return(list()) 346 } 347 if (is_formula(x)) { 348 return(simplify(x)) 349 } 350 list(x) 351} 352# From plyr:::as.quoted.formula 353simplify <- function(x) { 354 if (length(x) == 2 && is_symbol(x[[1]], "~")) { 355 return(simplify(x[[2]])) 356 } 357 if (length(x) < 3) { 358 return(list(x)) 359 } 360 op <- x[[1]]; a <- x[[2]]; b <- x[[3]] 361 362 if (is_symbol(op, c("+", "*", "~"))) { 363 c(simplify(a), simplify(b)) 364 } else if (is_symbol(op, "-")) { 365 c(simplify(a), expr(-!!simplify(b))) 366 } else { 367 list(x) 368 } 369} 370 371f_as_facets_list <- function(f) { 372 lhs <- function(x) if (length(x) == 2) NULL else x[-3] 373 rhs <- function(x) if (length(x) == 2) x else x[-2] 374 375 rows <- f_as_facets(lhs(f)) 376 cols <- f_as_facets(rhs(f)) 377 378 list(rows, cols) 379} 380 381as_facets <- function(x) { 382 if (is_facets(x)) { 383 return(x) 384 } 385 386 if (is_formula(x)) { 387 # Use different formula method because plyr's does not handle the 388 # environment correctly. 389 f_as_facets(x) 390 } else { 391 vars <- as_quoted(x) 392 as_quosures(vars, globalenv(), named = TRUE) 393 } 394} 395f_as_facets <- function(f) { 396 if (is.null(f)) { 397 return(as_quosures(list())) 398 } 399 400 env <- f_env(f) %||% globalenv() 401 402 # as.quoted() handles `+` specifications 403 vars <- as.quoted(f) 404 405 # `.` in formulas is ignored 406 vars <- discard_dots(vars) 407 408 as_quosures(vars, env, named = TRUE) 409} 410discard_dots <- function(x) { 411 x[!vapply(x, identical, logical(1), as.name("."))] 412} 413 414is_facets <- function(x) { 415 if (!is.list(x)) { 416 return(FALSE) 417 } 418 if (!length(x)) { 419 return(FALSE) 420 } 421 all(vapply(x, is_quosure, logical(1))) 422} 423 424 425# When evaluating variables in a facet specification, we evaluate bare 426# variables and expressions slightly differently. Bare variables should 427# always succeed, even if the variable doesn't exist in the data frame: 428# that makes it possible to repeat data across multiple factors. But 429# when evaluating an expression, you want to see any errors. That does 430# mean you can't have background data when faceting by an expression, 431# but that seems like a reasonable tradeoff. 432eval_facets <- function(facets, data, possible_columns = NULL) { 433 vars <- compact(lapply(facets, eval_facet, data, possible_columns = possible_columns)) 434 new_data_frame(tibble::as_tibble(vars)) 435} 436eval_facet <- function(facet, data, possible_columns = NULL) { 437 # Treat the case when `facet` is a quosure of a symbol specifically 438 # to issue a friendlier warning 439 if (quo_is_symbol(facet)) { 440 facet <- as.character(quo_get_expr(facet)) 441 442 if (facet %in% names(data)) { 443 out <- data[[facet]] 444 } else { 445 out <- NULL 446 } 447 return(out) 448 } 449 450 # Key idea: use active bindings so that column names missing in this layer 451 # but present in others raise a custom error 452 env <- new_environment(data) 453 missing_columns <- setdiff(possible_columns, names(data)) 454 undefined_error <- function(e) abort("", class = "ggplot2_missing_facet_var") 455 bindings <- rep_named(missing_columns, list(undefined_error)) 456 env_bind_active(env, !!!bindings) 457 458 # Create a data mask and install a data pronoun manually (see ?new_data_mask) 459 mask <- new_data_mask(env) 460 mask$.data <- as_data_pronoun(mask) 461 462 tryCatch( 463 eval_tidy(facet, mask), 464 ggplot2_missing_facet_var = function(e) NULL 465 ) 466} 467 468layout_null <- function() { 469 # PANEL needs to be a factor to be consistent with other facet types 470 new_data_frame(list(PANEL = factor(1), ROW = 1, COL = 1, SCALE_X = 1, SCALE_Y = 1)) 471} 472 473check_layout <- function(x) { 474 if (all(c("PANEL", "SCALE_X", "SCALE_Y") %in% names(x))) { 475 return() 476 } 477 478 abort("Facet layout has bad format. It must contain columns 'PANEL', 'SCALE_X', and 'SCALE_Y'") 479} 480 481 482#' Get the maximal width/length of a list of grobs 483#' 484#' @param grobs A list of grobs 485#' @param value_only Should the return value be a simple numeric vector giving 486#' the maximum in cm 487#' 488#' @return The largest value. measured in cm as a unit object or a numeric 489#' vector depending on `value_only` 490#' 491#' @keywords internal 492#' @export 493max_height <- function(grobs, value_only = FALSE) { 494 height <- max(unlist(lapply(grobs, height_cm))) 495 if (!value_only) height <- unit(height, "cm") 496 height 497} 498#' @rdname max_height 499#' @export 500max_width <- function(grobs, value_only = FALSE) { 501 width <- max(unlist(lapply(grobs, width_cm))) 502 if (!value_only) width <- unit(width, "cm") 503 width 504} 505#' Find panels in a gtable 506#' 507#' These functions help detect the placement of panels in a gtable, if they are 508#' named with "panel" in the beginning. `find_panel()` returns the extend of 509#' the panel area, while `panel_cols()` and `panel_rows()` returns the 510#' columns and rows that contains panels respectively. 511#' 512#' @param table A gtable 513#' 514#' @return A data.frame with some or all of the columns t(op), r(ight), 515#' b(ottom), and l(eft) 516#' 517#' @keywords internal 518#' @export 519find_panel <- function(table) { 520 layout <- table$layout 521 panels <- layout[grepl("^panel", layout$name), , drop = FALSE] 522 523 new_data_frame(list( 524 t = min(.subset2(panels, "t")), 525 r = max(.subset2(panels, "r")), 526 b = max(.subset2(panels, "b")), 527 l = min(.subset2(panels, "l")) 528 ), n = 1) 529} 530#' @rdname find_panel 531#' @export 532panel_cols = function(table) { 533 panels <- table$layout[grepl("^panel", table$layout$name), , drop = FALSE] 534 unique(panels[, c('l', 'r')]) 535} 536#' @rdname find_panel 537#' @export 538panel_rows <- function(table) { 539 panels <- table$layout[grepl("^panel", table$layout$name), , drop = FALSE] 540 unique(panels[, c('t', 'b')]) 541} 542#' Take input data and define a mapping between faceting variables and ROW, 543#' COL and PANEL keys 544#' 545#' @param data A list of data.frames, the first being the plot data and the 546#' subsequent individual layer data 547#' @param env The environment the vars should be evaluated in 548#' @param vars A list of quoted symbols matching columns in data 549#' @param drop should missing combinations/levels be dropped 550#' 551#' @return A data.frame with columns for PANEL, ROW, COL, and faceting vars 552#' 553#' @keywords internal 554#' @export 555combine_vars <- function(data, env = emptyenv(), vars = NULL, drop = TRUE) { 556 possible_columns <- unique(unlist(lapply(data, names))) 557 if (length(vars) == 0) return(new_data_frame()) 558 559 # For each layer, compute the facet values 560 values <- compact(lapply(data, eval_facets, facets = vars, possible_columns = possible_columns)) 561 562 # Form the base data.frame which contains all combinations of faceting 563 # variables that appear in the data 564 has_all <- unlist(lapply(values, length)) == length(vars) 565 if (!any(has_all)) { 566 missing <- lapply(values, function(x) setdiff(names(vars), names(x))) 567 missing_txt <- vapply(missing, var_list, character(1)) 568 name <- c("Plot", paste0("Layer ", seq_len(length(data) - 1))) 569 570 abort(glue( 571 "At least one layer must contain all faceting variables: {var_list(names(vars))}.\n", 572 glue_collapse(glue("* {name} is missing {missing_txt}"), "\n", last = "\n") 573 )) 574 } 575 576 base <- unique(rbind_dfs(values[has_all])) 577 if (!drop) { 578 base <- unique_combs(base) 579 } 580 581 # Systematically add on missing combinations 582 for (value in values[!has_all]) { 583 if (empty(value)) next; 584 585 old <- base[setdiff(names(base), names(value))] 586 new <- unique(value[intersect(names(base), names(value))]) 587 if (drop) { 588 new <- unique_combs(new) 589 } 590 base <- unique(rbind(base, df.grid(old, new))) 591 } 592 593 if (empty(base)) { 594 abort("Faceting variables must have at least one value") 595 } 596 597 base 598} 599#' Render panel axes 600#' 601#' These helpers facilitates generating theme compliant axes when 602#' building up the plot. 603#' 604#' @param x,y A list of ranges as available to the draw_panel method in 605#' `Facet` subclasses. 606#' @param coord A `Coord` object 607#' @param theme A `theme` object 608#' @param transpose Should the output be transposed? 609#' 610#' @return A list with the element "x" and "y" each containing axis 611#' specifications for the ranges passed in. Each axis specification is a list 612#' with a "top" and "bottom" element for x-axes and "left" and "right" element 613#' for y-axis, holding the respective axis grobs. Depending on the content of x 614#' and y some of the grobs might be zeroGrobs. If `transpose=TRUE` the 615#' content of the x and y elements will be transposed so e.g. all left-axes are 616#' collected in a left element as a list of grobs. 617#' 618#' @keywords internal 619#' @export 620#' 621render_axes <- function(x = NULL, y = NULL, coord, theme, transpose = FALSE) { 622 axes <- list() 623 if (!is.null(x)) { 624 axes$x <- lapply(x, coord$render_axis_h, theme) 625 } 626 if (!is.null(y)) { 627 axes$y <- lapply(y, coord$render_axis_v, theme) 628 } 629 if (transpose) { 630 axes <- list( 631 x = list( 632 top = lapply(axes$x, `[[`, "top"), 633 bottom = lapply(axes$x, `[[`, "bottom") 634 ), 635 y = list( 636 left = lapply(axes$y, `[[`, "left"), 637 right = lapply(axes$y, `[[`, "right") 638 ) 639 ) 640 } 641 axes 642} 643#' Render panel strips 644#' 645#' All positions are rendered and it is up to the facet to decide which to use 646#' 647#' @param x,y A data.frame with a column for each variable and a row for each 648#' combination to draw 649#' @param labeller A labeller function 650#' @param theme a `theme` object 651#' 652#' @return A list with an "x" and a "y" element, each containing a "top" and 653#' "bottom" or "left" and "right" element respectively. These contains a list of 654#' rendered strips as gtables. 655#' 656#' @keywords internal 657#' @export 658render_strips <- function(x = NULL, y = NULL, labeller, theme) { 659 list( 660 x = build_strip(x, labeller, theme, TRUE), 661 y = build_strip(y, labeller, theme, FALSE) 662 ) 663} 664