1#' @include facet-.r
2NULL
3
4#' Lay out panels in a grid
5#'
6#' `facet_grid()` forms a matrix of panels defined by row and column
7#' faceting variables. It is most useful when you have two discrete
8#' variables, and all combinations of the variables exist in the data.
9#' If you have only one variable with many levels, try [facet_wrap()].
10#'
11#' @param rows,cols A set of variables or expressions quoted by
12#'   [vars()] and defining faceting groups on the rows or columns
13#'   dimension. The variables can be named (the names are passed to
14#'   `labeller`).
15#'
16#'   For compatibility with the classic interface, `rows` can also be
17#'   a formula with the rows (of the tabular display) on the LHS and
18#'   the columns (of the tabular display) on the RHS; the dot in the
19#'   formula is used to indicate there should be no faceting on this
20#'   dimension (either row or column).
21#' @param scales Are scales shared across all facets (the default,
22#'   `"fixed"`), or do they vary across rows (`"free_x"`),
23#'   columns (`"free_y"`), or both rows and columns (`"free"`)?
24#' @param space If `"fixed"`, the default, all panels have the same size.
25#'   If `"free_y"` their height will be proportional to the length of the
26#'   y scale; if `"free_x"` their width will be proportional to the
27#'  length of the x scale; or if `"free"` both height and width will
28#'  vary.  This setting has no effect unless the appropriate scales also vary.
29#' @param labeller A function that takes one data frame of labels and
30#'   returns a list or data frame of character vectors. Each input
31#'   column corresponds to one factor. Thus there will be more than
32#'   one with `vars(cyl, am)`. Each output
33#'   column gets displayed as one separate line in the strip
34#'   label. This function should inherit from the "labeller" S3 class
35#'   for compatibility with [labeller()]. You can use different labeling
36#'   functions for different kind of labels, for example use [label_parsed()] for
37#'   formatting facet labels. [label_value()] is used by default,
38#'   check it for more details and pointers to other options.
39#' @param as.table If `TRUE`, the default, the facets are laid out like
40#'   a table with highest values at the bottom-right. If `FALSE`, the
41#'   facets are laid out like a plot with the highest value at the top-right.
42#' @param switch By default, the labels are displayed on the top and
43#'   right of the plot. If `"x"`, the top labels will be
44#'   displayed to the bottom. If `"y"`, the right-hand side
45#'   labels will be displayed to the left. Can also be set to
46#'   `"both"`.
47#' @param shrink If `TRUE`, will shrink scales to fit output of
48#'   statistics, not raw data. If `FALSE`, will be range of raw data
49#'   before statistical summary.
50#' @param drop If `TRUE`, the default, all factor levels not used in the
51#'   data will automatically be dropped. If `FALSE`, all factor levels
52#'   will be shown, regardless of whether or not they appear in the data.
53#' @param margins Either a logical value or a character
54#'   vector. Margins are additional facets which contain all the data
55#'   for each of the possible values of the faceting variables. If
56#'   `FALSE`, no additional facets are included (the
57#'   default). If `TRUE`, margins are included for all faceting
58#'   variables. If specified as a character vector, it is the names of
59#'   variables for which margins are to be created.
60#' @param facets This argument is soft-deprecated, please use `rows`
61#'   and `cols` instead.
62#' @export
63#' @examples
64#' p <- ggplot(mpg, aes(displ, cty)) + geom_point()
65#'
66#' # Use vars() to supply variables from the dataset:
67#' p + facet_grid(rows = vars(drv))
68#' p + facet_grid(cols = vars(cyl))
69#' p + facet_grid(vars(drv), vars(cyl))
70#'
71#' # To change plot order of facet grid,
72#' # change the order of variable levels with factor()
73#'
74#' # If you combine a facetted dataset with a dataset that lacks those
75#' # faceting variables, the data will be repeated across the missing
76#' # combinations:
77#' df <- data.frame(displ = mean(mpg$displ), cty = mean(mpg$cty))
78#' p +
79#'   facet_grid(cols = vars(cyl)) +
80#'   geom_point(data = df, colour = "red", size = 2)
81#'
82#' # Free scales -------------------------------------------------------
83#' # You can also choose whether the scales should be constant
84#' # across all panels (the default), or whether they should be allowed
85#' # to vary
86#' mt <- ggplot(mtcars, aes(mpg, wt, colour = factor(cyl))) +
87#'   geom_point()
88#'
89#' mt + facet_grid(vars(cyl), scales = "free")
90#'
91#' # If scales and space are free, then the mapping between position
92#' # and values in the data will be the same across all panels. This
93#' # is particularly useful for categorical axes
94#' ggplot(mpg, aes(drv, model)) +
95#'   geom_point() +
96#'   facet_grid(manufacturer ~ ., scales = "free", space = "free") +
97#'   theme(strip.text.y = element_text(angle = 0))
98#'
99#' # Margins ----------------------------------------------------------
100#' \donttest{
101#' # Margins can be specified logically (all yes or all no) or for specific
102#' # variables as (character) variable names
103#' mg <- ggplot(mtcars, aes(x = mpg, y = wt)) + geom_point()
104#' mg + facet_grid(vs + am ~ gear, margins = TRUE)
105#' mg + facet_grid(vs + am ~ gear, margins = "am")
106#' # when margins are made over "vs", since the facets for "am" vary
107#' # within the values of "vs", the marginal facet for "vs" is also
108#' # a margin over "am".
109#' mg + facet_grid(vs + am ~ gear, margins = "vs")
110#' }
111facet_grid <- function(rows = NULL, cols = NULL, scales = "fixed",
112                       space = "fixed", shrink = TRUE,
113                       labeller = "label_value", as.table = TRUE,
114                       switch = NULL, drop = TRUE, margins = FALSE,
115                       facets = NULL) {
116  # `facets` is soft-deprecated and renamed to `rows`
117  if (!is.null(facets)) {
118    rows <- facets
119  }
120  # Should become a warning in a future release
121  if (is.logical(cols)) {
122    margins <- cols
123    cols <- NULL
124  }
125
126  scales <- match.arg(scales, c("fixed", "free_x", "free_y", "free"))
127  free <- list(
128    x = any(scales %in% c("free_x", "free")),
129    y = any(scales %in% c("free_y", "free"))
130  )
131
132  space <- match.arg(space, c("fixed", "free_x", "free_y", "free"))
133  space_free <- list(
134    x = any(space %in% c("free_x", "free")),
135    y = any(space %in% c("free_y", "free"))
136  )
137
138  if (!is.null(switch) && !switch %in% c("both", "x", "y")) {
139    abort("switch must be either 'both', 'x', or 'y'")
140  }
141
142  facets_list <- grid_as_facets_list(rows, cols)
143
144  # Check for deprecated labellers
145  labeller <- check_labeller(labeller)
146
147  ggproto(NULL, FacetGrid,
148    shrink = shrink,
149    params = list(rows = facets_list$rows, cols = facets_list$cols, margins = margins,
150      free = free, space_free = space_free, labeller = labeller,
151      as.table = as.table, switch = switch, drop = drop)
152  )
153}
154
155# Returns a list of quosures objects. The list has exactly two elements, `rows` and `cols`.
156grid_as_facets_list <- function(rows, cols) {
157  is_rows_vars <- is.null(rows) || is_quosures(rows)
158  if (!is_rows_vars) {
159    if (!is.null(cols)) {
160      msg <- "`rows` must be `NULL` or a `vars()` list if `cols` is a `vars()` list"
161      if(inherits(rows, "ggplot")) {
162        msg <- paste0(
163          msg, "\n",
164          "Did you use %>% instead of +?"
165        )
166      }
167      abort(msg)
168    }
169    # For backward-compatibility
170    facets_list <- as_facets_list(rows)
171    if (length(facets_list) > 2L) {
172      abort("A grid facet specification can't have more than two dimensions")
173    }
174    # Fill with empty quosures
175    facets <- list(rows = quos(), cols = quos())
176    facets[seq_along(facets_list)] <- facets_list
177    # Do not compact the legacy specs
178    return(facets)
179  }
180
181  is_cols_vars <- is.null(cols) || is_quosures(cols)
182  if (!is_cols_vars) {
183    abort("`cols` must be `NULL` or a `vars()` specification")
184  }
185
186  list(
187    rows = compact_facets(as_facets_list(rows)),
188    cols = compact_facets(as_facets_list(cols))
189  )
190}
191
192#' @rdname ggplot2-ggproto
193#' @format NULL
194#' @usage NULL
195#' @export
196FacetGrid <- ggproto("FacetGrid", Facet,
197  shrink = TRUE,
198
199  compute_layout = function(data, params) {
200    rows <- params$rows
201    cols <- params$cols
202
203    dups <- intersect(names(rows), names(cols))
204    if (length(dups) > 0) {
205      abort(glue(
206        "Faceting variables can only appear in row or cols, not both.\n",
207        "Problems: ", paste0(dups, collapse = "'")
208      ))
209    }
210
211    base_rows <- combine_vars(data, params$plot_env, rows, drop = params$drop)
212    if (!params$as.table) {
213      rev_order <- function(x) factor(x, levels = rev(ulevels(x)))
214      base_rows[] <- lapply(base_rows, rev_order)
215    }
216    base_cols <- combine_vars(data, params$plot_env, cols, drop = params$drop)
217    base <- df.grid(base_rows, base_cols)
218
219    if (nrow(base) == 0) {
220      return(new_data_frame(list(PANEL = factor(1L), ROW = 1L, COL = 1L, SCALE_X = 1L, SCALE_Y = 1L)))
221    }
222
223    # Add margins
224    base <- reshape_add_margins(base, list(names(rows), names(cols)), params$margins)
225    base <- unique(base)
226
227    # Create panel info dataset
228    panel <- id(base, drop = TRUE)
229    panel <- factor(panel, levels = seq_len(attr(panel, "n")))
230
231    rows <- if (!length(names(rows))) rep(1L, length(panel)) else id(base[names(rows)], drop = TRUE)
232    cols <- if (!length(names(cols))) rep(1L, length(panel)) else id(base[names(cols)], drop = TRUE)
233
234    panels <- new_data_frame(c(list(PANEL = panel, ROW = rows, COL = cols), base))
235    panels <- panels[order(panels$PANEL), , drop = FALSE]
236    rownames(panels) <- NULL
237
238    panels$SCALE_X <- if (params$free$x) panels$COL else 1L
239    panels$SCALE_Y <- if (params$free$y) panels$ROW else 1L
240
241    panels
242  },
243  map_data = function(data, layout, params) {
244    if (empty(data)) {
245      return(cbind(data, PANEL = integer(0)))
246    }
247
248    rows <- params$rows
249    cols <- params$cols
250    vars <- c(names(rows), names(cols))
251
252    if (length(vars) == 0) {
253      data$PANEL <- layout$PANEL
254      return(data)
255    }
256
257    # Compute faceting values and add margins
258    margin_vars <- list(intersect(names(rows), names(data)),
259      intersect(names(cols), names(data)))
260    data <- reshape_add_margins(data, margin_vars, params$margins)
261
262    facet_vals <- eval_facets(c(rows, cols), data, params$.possible_columns)
263
264    # If any faceting variables are missing, add them in by
265    # duplicating the data
266    missing_facets <- setdiff(vars, names(facet_vals))
267    if (length(missing_facets) > 0) {
268      to_add <- unique(layout[missing_facets])
269
270      data_rep <- rep.int(1:nrow(data), nrow(to_add))
271      facet_rep <- rep(1:nrow(to_add), each = nrow(data))
272
273      data <- unrowname(data[data_rep, , drop = FALSE])
274      facet_vals <- unrowname(cbind(
275        facet_vals[data_rep, ,  drop = FALSE],
276        to_add[facet_rep, , drop = FALSE]))
277    }
278
279    # Add PANEL variable
280    if (nrow(facet_vals) == 0) {
281      # Special case of no faceting
282      data$PANEL <- NO_PANEL
283    } else {
284      facet_vals[] <- lapply(facet_vals[], as.factor)
285      facet_vals[] <- lapply(facet_vals[], addNA, ifany = TRUE)
286
287      keys <- join_keys(facet_vals, layout, by = vars)
288
289      data$PANEL <- layout$PANEL[match(keys$x, keys$y)]
290    }
291    data
292  },
293  draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) {
294    if ((params$free$x || params$free$y) && !coord$is_free()) {
295      abort(glue("{snake_class(coord)} doesn't support free scales"))
296    }
297
298    cols <- which(layout$ROW == 1)
299    rows <- which(layout$COL == 1)
300    axes <- render_axes(ranges[cols], ranges[rows], coord, theme, transpose = TRUE)
301
302    col_vars <- unique(layout[names(params$cols)])
303    row_vars <- unique(layout[names(params$rows)])
304    # Adding labels metadata, useful for labellers
305    attr(col_vars, "type") <- "cols"
306    attr(col_vars, "facet") <- "grid"
307    attr(row_vars, "type") <- "rows"
308    attr(row_vars, "facet") <- "grid"
309    strips <- render_strips(col_vars, row_vars, params$labeller, theme)
310
311    aspect_ratio <- theme$aspect.ratio
312    if (!is.null(aspect_ratio) && (params$space_free$x || params$space_free$y)) {
313      abort("Free scales cannot be mixed with a fixed aspect ratio")
314    }
315    if (is.null(aspect_ratio) && !params$free$x && !params$free$y) {
316      aspect_ratio <- coord$aspect(ranges[[1]])
317    }
318    if (is.null(aspect_ratio)) {
319      aspect_ratio <- 1
320      respect <- FALSE
321    } else {
322      respect <- TRUE
323    }
324    ncol <- max(layout$COL)
325    nrow <- max(layout$ROW)
326    panel_table <- matrix(panels, nrow = nrow, ncol = ncol, byrow = TRUE)
327
328    # @kohske
329    # Now size of each panel is calculated using PANEL$ranges, which is given by
330    # coord_train called by train_range.
331    # So here, "scale" need not to be referred.
332    #
333    # In general, panel has all information for building facet.
334    if (params$space_free$x) {
335      ps <- layout$PANEL[layout$ROW == 1]
336      widths <- vapply(ps, function(i) diff(ranges[[i]]$x.range), numeric(1))
337      panel_widths <- unit(widths, "null")
338    } else {
339      panel_widths <- rep(unit(1, "null"), ncol)
340    }
341    if (params$space_free$y) {
342      ps <- layout$PANEL[layout$COL == 1]
343      heights <- vapply(ps, function(i) diff(ranges[[i]]$y.range), numeric(1))
344      panel_heights <- unit(heights, "null")
345    } else {
346      panel_heights <- rep(unit(1 * abs(aspect_ratio), "null"), nrow)
347    }
348
349    panel_table <- gtable_matrix("layout", panel_table,
350      panel_widths, panel_heights, respect = respect, clip = coord$clip, z = matrix(1, ncol = ncol, nrow = nrow))
351    panel_table$layout$name <- paste0('panel-', rep(seq_len(nrow), ncol), '-', rep(seq_len(ncol), each = nrow))
352
353    panel_table <- gtable_add_col_space(panel_table,
354      theme$panel.spacing.x %||% theme$panel.spacing)
355    panel_table <- gtable_add_row_space(panel_table,
356      theme$panel.spacing.y %||% theme$panel.spacing)
357
358    # Add axes
359    panel_table <- gtable_add_rows(panel_table, max_height(axes$x$top), 0)
360    panel_table <- gtable_add_rows(panel_table, max_height(axes$x$bottom), -1)
361    panel_table <- gtable_add_cols(panel_table, max_width(axes$y$left), 0)
362    panel_table <- gtable_add_cols(panel_table, max_width(axes$y$right), -1)
363    panel_pos_col <- panel_cols(panel_table)
364    panel_pos_rows <- panel_rows(panel_table)
365
366    panel_table <- 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)
367    panel_table <- 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)
368    panel_table <- 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)
369    panel_table <- 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)
370
371    # Add strips
372    switch_x <- !is.null(params$switch) && params$switch %in% c("both", "x")
373    switch_y <- !is.null(params$switch) && params$switch %in% c("both", "y")
374    inside_x <- (theme$strip.placement.x %||% theme$strip.placement %||% "inside") == "inside"
375    inside_y <- (theme$strip.placement.y %||% theme$strip.placement %||% "inside") == "inside"
376    strip_padding <- convertUnit(theme$strip.switch.pad.grid, "cm")
377    panel_pos_col <- panel_cols(panel_table)
378    if (switch_x) {
379      if (!is.null(strips$x$bottom)) {
380        if (inside_x) {
381          panel_table <- gtable_add_rows(panel_table, max_height(strips$x$bottom), -2)
382          panel_table <- 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)
383        } else {
384          panel_table <- gtable_add_rows(panel_table, strip_padding, -1)
385          panel_table <- gtable_add_rows(panel_table, max_height(strips$x$bottom), -1)
386          panel_table <- 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)
387        }
388      }
389    } else {
390      if (!is.null(strips$x$top)) {
391        if (inside_x) {
392          panel_table <- gtable_add_rows(panel_table, max_height(strips$x$top), 1)
393          panel_table <- 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)
394        } else {
395          panel_table <- gtable_add_rows(panel_table, strip_padding, 0)
396          panel_table <- gtable_add_rows(panel_table, max_height(strips$x$top), 0)
397          panel_table <- 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)
398        }
399      }
400    }
401    panel_pos_rows <- panel_rows(panel_table)
402    if (switch_y) {
403      if (!is.null(strips$y$left)) {
404        if (inside_y) {
405          panel_table <- gtable_add_cols(panel_table, max_width(strips$y$left), 1)
406          panel_table <- 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)
407        } else {
408          panel_table <- gtable_add_cols(panel_table, strip_padding, 0)
409          panel_table <- gtable_add_cols(panel_table, max_width(strips$y$left), 0)
410          panel_table <- 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)
411        }
412      }
413    } else {
414      if (!is.null(strips$y$right)) {
415        if (inside_y) {
416          panel_table <- gtable_add_cols(panel_table, max_width(strips$y$right), -2)
417          panel_table <- 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)
418        } else {
419          panel_table <- gtable_add_cols(panel_table, strip_padding, -1)
420          panel_table <- gtable_add_cols(panel_table, max_width(strips$y$right), -1)
421          panel_table <- 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)
422        }
423      }
424    }
425    panel_table
426  },
427  vars = function(self) {
428    names(c(self$params$rows, self$params$cols))
429  }
430)
431
432# Helpers -----------------------------------------------------------------
433
434ulevels <- function(x) {
435  if (is.factor(x)) {
436    x <- addNA(x, TRUE)
437    factor(levels(x), levels(x), exclude = NULL)
438  } else {
439    sort(unique(x))
440  }
441}
442