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