In order to continuously monitor the performance of gtable the following piece of code is used to generate a profile and inspect it:
library(ggplot2)
library(profvis)
p <- ggplot(mtcars, aes(mpg, disp)) +
geom_point() +
facet_grid(gear~cyl)
p_build <- ggplot_build(p)
profile <- profvis(for (i in seq_len(100)) ggplot_gtable(p_build))
profileFlame Graph
Data
| ggplot2/R/geom-point.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Points | ||||||||
| #' | ||||||||
| #' The point geom is used to create scatterplots. The scatterplot is most | ||||||||
| #' useful for displaying the relationship between two continuous variables. | ||||||||
| #' It can be used to compare one continuous and one categorical variable, or | ||||||||
| #' two categorical variables, but a variation like [geom_jitter()], | ||||||||
| #' [geom_count()], or [geom_bin2d()] is usually more | ||||||||
| #' appropriate. A _bubblechart_ is a scatterplot with a third variable | ||||||||
| #' mapped to the size of points. | ||||||||
| #' | ||||||||
| #' @section Overplotting: | ||||||||
| #' The biggest potential problem with a scatterplot is overplotting: whenever | ||||||||
| #' you have more than a few points, points may be plotted on top of one | ||||||||
| #' another. This can severely distort the visual appearance of the plot. | ||||||||
| #' There is no one solution to this problem, but there are some techniques | ||||||||
| #' that can help. You can add additional information with | ||||||||
| #' [geom_smooth()], [geom_quantile()] or | ||||||||
| #' [geom_density_2d()]. If you have few unique `x` values, | ||||||||
| #' [geom_boxplot()] may also be useful. | ||||||||
| #' | ||||||||
| #' Alternatively, you can | ||||||||
| #' summarise the number of points at each location and display that in some | ||||||||
| #' way, using [geom_count()], [geom_hex()], or | ||||||||
| #' [geom_density2d()]. | ||||||||
| #' | ||||||||
| #' Another technique is to make the points transparent (e.g. | ||||||||
| #' `geom_point(alpha = 0.05)`) or very small (e.g. | ||||||||
| #' `geom_point(shape = ".")`). | ||||||||
| #' | ||||||||
| #' @eval rd_aesthetics("geom", "point") | ||||||||
| #' @inheritParams layer | ||||||||
| #' @param na.rm If `FALSE`, the default, missing values are removed with | ||||||||
| #' a warning. If `TRUE`, missing values are silently removed. | ||||||||
| #' @param ... Other arguments passed on to [layer()]. These are | ||||||||
| #' often aesthetics, used to set an aesthetic to a fixed value, like | ||||||||
| #' `colour = "red"` or `size = 3`. They may also be parameters | ||||||||
| #' to the paired geom/stat. | ||||||||
| #' @inheritParams layer | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' p <- ggplot(mtcars, aes(wt, mpg)) | ||||||||
| #' p + geom_point() | ||||||||
| #' | ||||||||
| #' # Add aesthetic mappings | ||||||||
| #' p + geom_point(aes(colour = factor(cyl))) | ||||||||
| #' p + geom_point(aes(shape = factor(cyl))) | ||||||||
| #' # A "bubblechart": | ||||||||
| #' p + geom_point(aes(size = qsec)) | ||||||||
| #' | ||||||||
| #' # Set aesthetics to fixed value | ||||||||
| #' ggplot(mtcars, aes(wt, mpg)) + geom_point(colour = "red", size = 3) | ||||||||
| #' | ||||||||
| #' \donttest{ | ||||||||
| #' # Varying alpha is useful for large datasets | ||||||||
| #' d <- ggplot(diamonds, aes(carat, price)) | ||||||||
| #' d + geom_point(alpha = 1/10) | ||||||||
| #' d + geom_point(alpha = 1/20) | ||||||||
| #' d + geom_point(alpha = 1/100) | ||||||||
| #' } | ||||||||
| #' | ||||||||
| #' # For shapes that have a border (like 21), you can colour the inside and | ||||||||
| #' # outside separately. Use the stroke aesthetic to modify the width of the | ||||||||
| #' # border | ||||||||
| #' ggplot(mtcars, aes(wt, mpg)) + | ||||||||
| #' geom_point(shape = 21, colour = "black", fill = "white", size = 5, stroke = 5) | ||||||||
| #' | ||||||||
| #' \donttest{ | ||||||||
| #' # You can create interesting shapes by layering multiple points of | ||||||||
| #' # different sizes | ||||||||
| #' p <- ggplot(mtcars, aes(mpg, wt, shape = factor(cyl))) | ||||||||
| #' p + geom_point(aes(colour = factor(cyl)), size = 4) + | ||||||||
| #' geom_point(colour = "grey90", size = 1.5) | ||||||||
| #' p + geom_point(colour = "black", size = 4.5) + | ||||||||
| #' geom_point(colour = "pink", size = 4) + | ||||||||
| #' geom_point(aes(shape = factor(cyl))) | ||||||||
| #' | ||||||||
| #' # geom_point warns when missing values have been dropped from the data set | ||||||||
| #' # and not plotted, you can turn this off by setting na.rm = TRUE | ||||||||
| #' mtcars2 <- transform(mtcars, mpg = ifelse(runif(32) < 0.2, NA, mpg)) | ||||||||
| #' ggplot(mtcars2, aes(wt, mpg)) + geom_point() | ||||||||
| #' ggplot(mtcars2, aes(wt, mpg)) + geom_point(na.rm = TRUE) | ||||||||
| #' } | ||||||||
| geom_point <- function(mapping = NULL, data = NULL, | ||||||||
| stat = "identity", position = "identity", | ||||||||
| ..., | ||||||||
| na.rm = FALSE, | ||||||||
| show.legend = NA, | ||||||||
| inherit.aes = TRUE) { | ||||||||
| layer( | ||||||||
| data = data, | ||||||||
| mapping = mapping, | ||||||||
| stat = stat, | ||||||||
| geom = GeomPoint, | ||||||||
| position = position, | ||||||||
| show.legend = show.legend, | ||||||||
| inherit.aes = inherit.aes, | ||||||||
| params = list( | ||||||||
| na.rm = na.rm, | ||||||||
| ... | ||||||||
| ) | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @rdname ggplot2-ggproto | ||||||||
| #' @format NULL | ||||||||
| #' @usage NULL | ||||||||
| #' @export | ||||||||
| GeomPoint <- ggproto("GeomPoint", Geom, | ||||||||
| required_aes = c("x", "y"), | ||||||||
| non_missing_aes = c("size", "shape", "colour"), | ||||||||
| default_aes = aes( | ||||||||
| shape = 19, colour = "black", size = 1.5, fill = NA, | ||||||||
| alpha = NA, stroke = 0.5 | ||||||||
| ), | ||||||||
| draw_panel = function(data, panel_params, coord, na.rm = FALSE) { | ||||||||
| if (is.character(data$shape)) { | ||||||||
| data$shape <- translate_shape_string(data$shape) | ||||||||
| } | ||||||||
| coords <- coord$transform(data, panel_params) | ||||||||
| ggname("geom_point", | ||||||||
| pointsGrob( | ||||||||
| coords$x, coords$y, | ||||||||
| pch = coords$shape, | ||||||||
| gp = gpar( | ||||||||
| col = alpha(coords$colour, coords$alpha), | ||||||||
| fill = alpha(coords$fill, coords$alpha), | ||||||||
| # Stroke is added around the outside of the point | ||||||||
| fontsize = coords$size * .pt + coords$stroke * .stroke / 2, | ||||||||
| lwd = coords$stroke * .stroke / 2 | ||||||||
| ) | ||||||||
| ) | ||||||||
| ) | ||||||||
| }, | ||||||||
| draw_key = draw_key_point | ||||||||
| ) | ||||||||
| translate_shape_string <- function(shape_string) { | ||||||||
| # strings of length 0 or 1 are interpreted as symbols by grid | ||||||||
| if (nchar(shape_string[1]) <= 1) { | ||||||||
| return(shape_string) | ||||||||
| } | ||||||||
| pch_table <- c( | ||||||||
| "square open" = 0, | ||||||||
| "circle open" = 1, | ||||||||
| "triangle open" = 2, | ||||||||
| "plus" = 3, | ||||||||
| "cross" = 4, | ||||||||
| "diamond open" = 5, | ||||||||
| "triangle down open" = 6, | ||||||||
| "square cross" = 7, | ||||||||
| "asterisk" = 8, | ||||||||
| "diamond plus" = 9, | ||||||||
| "circle plus" = 10, | ||||||||
| "star" = 11, | ||||||||
| "square plus" = 12, | ||||||||
| "circle cross" = 13, | ||||||||
| "square triangle" = 14, | ||||||||
| "triangle square" = 14, | ||||||||
| "square" = 15, | ||||||||
| "circle small" = 16, | ||||||||
| "triangle" = 17, | ||||||||
| "diamond" = 18, | ||||||||
| "circle" = 19, | ||||||||
| "bullet" = 20, | ||||||||
| "circle filled" = 21, | ||||||||
| "square filled" = 22, | ||||||||
| "diamond filled" = 23, | ||||||||
| "triangle filled" = 24, | ||||||||
| "triangle down filled" = 25 | ||||||||
| ) | ||||||||
| shape_match <- charmatch(shape_string, names(pch_table)) | ||||||||
| invalid_strings <- is.na(shape_match) | ||||||||
| nonunique_strings <- shape_match == 0 | ||||||||
| if (any(invalid_strings)) { | ||||||||
| bad_string <- unique(shape_string[invalid_strings]) | ||||||||
| n_bad <- length(bad_string) | ||||||||
| collapsed_names <- sprintf("\n* '%s'", bad_string[1:min(5, n_bad)]) | ||||||||
| more_problems <- if (n_bad > 5) { | ||||||||
| sprintf("\n* ... and %d more problem%s", n_bad - 5, ifelse(n_bad > 6, "s", "")) | ||||||||
| } | ||||||||
| stop( | ||||||||
| "Can't find shape name:", | ||||||||
| collapsed_names, | ||||||||
| more_problems, | ||||||||
| call. = FALSE | ||||||||
| ) | ||||||||
| } | ||||||||
| if (any(nonunique_strings)) { | ||||||||
| bad_string <- unique(shape_string[nonunique_strings]) | ||||||||
| n_bad <- length(bad_string) | ||||||||
| n_matches <- vapply( | ||||||||
| bad_string[1:min(5, n_bad)], | ||||||||
| function(shape_string) sum(grepl(paste0("^", shape_string), names(pch_table))), | ||||||||
| integer(1) | ||||||||
| ) | ||||||||
| collapsed_names <- sprintf( | ||||||||
| "\n* '%s' partially matches %d shape names", | ||||||||
| bad_string[1:min(5, n_bad)], n_matches | ||||||||
| ) | ||||||||
| more_problems <- if (n_bad > 5) { | ||||||||
| sprintf("\n* ... and %d more problem%s", n_bad - 5, ifelse(n_bad > 6, "s", "")) | ||||||||
| } | ||||||||
| stop( | ||||||||
| "Shape names must be unambiguous:", | ||||||||
| collapsed_names, | ||||||||
| more_problems, | ||||||||
| call. = FALSE | ||||||||
| ) | ||||||||
| } | ||||||||
| unname(pch_table[shape_match]) | ||||||||
| } | ||||||||
| ggplot2/R/utilities-grid.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' @export | ||||||||
| grid::unit | ||||||||
| #' @export | ||||||||
| grid::arrow | ||||||||
| # Name ggplot grid object | ||||||||
| # Convenience function to name grid objects | ||||||||
| # | ||||||||
| # @keyword internal | ||||||||
| ggname <- function(prefix, grob) { | ||||||||
| grob$name <- grobName(grob, prefix) | ||||||||
| grob | ||||||||
| } | ||||||||
| width_cm <- function(x) { | ||||||||
| if (is.grob(x)) { | ||||||||
| convertWidth(grobWidth(x), "cm", TRUE) | ||||||||
| } else if (is.unit(x)) { | ||||||||
| convertWidth(x, "cm", TRUE) | ||||||||
| } else if (is.list(x)) { | ||||||||
| vapply(x, width_cm, numeric(1)) | ||||||||
| } else { | ||||||||
| stop("Unknown input") | ||||||||
| } | ||||||||
| } | ||||||||
| height_cm <- function(x) { | ||||||||
| if (is.grob(x)) { | ||||||||
| convertHeight(grobHeight(x), "cm", TRUE) | ||||||||
| } else if (is.unit(x)) { | ||||||||
| convertHeight(x, "cm", TRUE) | ||||||||
| } else if (is.list(x)) { | ||||||||
| vapply(x, height_cm, numeric(1)) | ||||||||
| } else { | ||||||||
| stop("Unknown input") | ||||||||
| } | ||||||||
| } | ||||||||
| ggplot2/R/ggproto.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Create a new ggproto object | ||||||||
| #' | ||||||||
| #' Construct a new object with `ggproto`, test with `is.proto`, | ||||||||
| #' and access parent methods/fields with `ggproto_parent`. | ||||||||
| #' | ||||||||
| #' ggproto implements a protype based OO system which blurs the lines between | ||||||||
| #' classes and instances. It is inspired by the proto package, but it has some | ||||||||
| #' important differences. Notably, it cleanly supports cross-package | ||||||||
| #' inheritance, and has faster performance. | ||||||||
| #' | ||||||||
| #' In most cases, creating a new OO system to be used by a single package is | ||||||||
| #' not a good idea. However, it was the least-bad solution for ggplot2 because | ||||||||
| #' it required the fewest changes to an already complex code base. | ||||||||
| #' | ||||||||
| #' @section Calling methods: | ||||||||
| #' ggproto methods can take an optional `self` argument: if it is present, | ||||||||
| #' it is a regular method; if it's absent, it's a "static" method (i.e. it | ||||||||
| #' doesn't use any fields). | ||||||||
| #' | ||||||||
| #' Imagine you have a ggproto object `Adder`, which has a | ||||||||
| #' method `addx = function(self, n) n + self$x`. Then, to call this | ||||||||
| #' function, you would use `Adder$addx(10)` -- the `self` is passed | ||||||||
| #' in automatically by the wrapper function. `self` be located anywhere | ||||||||
| #' in the function signature, although customarily it comes first. | ||||||||
| #' | ||||||||
| #' @section Calling methods in a parent: | ||||||||
| #' To explicitly call a methods in a parent, use | ||||||||
| #' `ggproto_parent(Parent, self)`. | ||||||||
| #' | ||||||||
| #' @param _class Class name to assign to the object. This is stored as the class | ||||||||
| #' attribute of the object. This is optional: if `NULL` (the default), | ||||||||
| #' no class name will be added to the object. | ||||||||
| #' @param _inherit ggproto object to inherit from. If `NULL`, don't | ||||||||
| #' inherit from any object. | ||||||||
| #' @param ... A list of members in the ggproto object. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' Adder <- ggproto("Adder", | ||||||||
| #' x = 0, | ||||||||
| #' add = function(self, n) { | ||||||||
| #' self$x <- self$x + n | ||||||||
| #' self$x | ||||||||
| #' } | ||||||||
| #' ) | ||||||||
| #' is.ggproto(Adder) | ||||||||
| #' | ||||||||
| #' Adder$add(10) | ||||||||
| #' Adder$add(10) | ||||||||
| #' | ||||||||
| #' Doubler <- ggproto("Doubler", Adder, | ||||||||
| #' add = function(self, n) { | ||||||||
| #' ggproto_parent(Adder, self)$add(n * 2) | ||||||||
| #' } | ||||||||
| #' ) | ||||||||
| #' Doubler$x | ||||||||
| #' Doubler$add(10) | ||||||||
| ggproto <- function(`_class` = NULL, `_inherit` = NULL, ...) { | ||||||||
| e <- new.env(parent = emptyenv()) | ||||||||
| members <- list(...) | ||||||||
| if (length(members) != sum(nzchar(names(members)))) { | ||||||||
| stop("All members of a ggproto object must be named.") | ||||||||
| } | ||||||||
| # R <3.1.2 will error when list2env() is given an empty list, so we need to | ||||||||
| # check length. https://github.com/tidyverse/ggplot2/issues/1444 | ||||||||
| if (length(members) > 0) { | ||||||||
| list2env(members, envir = e) | ||||||||
| } | ||||||||
| # Dynamically capture parent: this is necessary in order to avoid | ||||||||
| # capturing the parent at package build time. | ||||||||
| `_inherit` <- substitute(`_inherit`) | ||||||||
| env <- parent.frame() | ||||||||
| find_super <- function() { | ||||||||
| eval(`_inherit`, env, NULL) | ||||||||
| } | ||||||||
| super <- find_super() | ||||||||
| if (!is.null(super)) { | ||||||||
| if (!is.ggproto(super)) { | ||||||||
| stop("`_inherit` must be a ggproto object.") | ||||||||
| } | ||||||||
| e$super <- find_super | ||||||||
| class(e) <- c(`_class`, class(super)) | ||||||||
| } else { | ||||||||
| class(e) <- c(`_class`, "ggproto", "gg") | ||||||||
| } | ||||||||
| e | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname ggproto | ||||||||
| #' @param parent,self Access parent class `parent` of object `self`. | ||||||||
| ggproto_parent <- function(parent, self) { | ||||||||
| structure(list(parent = parent, self = self), class = "ggproto_parent") | ||||||||
| } | ||||||||
| #' @param x An object to test. | ||||||||
| #' @export | ||||||||
| #' @rdname ggproto | ||||||||
| is.ggproto <- function(x) inherits(x, "ggproto") | ||||||||
| fetch_ggproto <- function(x, name) { | ||||||||
| res <- NULL | ||||||||
| val <- .subset2(x, name) | ||||||||
| # The is.null check is an optimization for a common case; exists() also | ||||||||
| # catches the case where the value exists but has a NULL value. | ||||||||
| if (!is.null(val) || exists(name, envir = x, inherits = FALSE)) { | ||||||||
| res <- val | ||||||||
| } else { | ||||||||
| # If not found here, recurse into super environments | ||||||||
| super <- .subset2(x, "super") | ||||||||
| if (is.null(super)) { | ||||||||
| # no super class | ||||||||
| } else if (is.function(super)) { | ||||||||
| res <- fetch_ggproto(super(), name) | ||||||||
| } else { | ||||||||
| stop( | ||||||||
| class(x)[[1]], " was built with an incompatible version of ggproto.\n", | ||||||||
| "Please reinstall the package that provides this extension.", | ||||||||
| call. = FALSE | ||||||||
| ) | ||||||||
| } | ||||||||
| } | ||||||||
| res | ||||||||
| } | ||||||||
| #' @importFrom utils .DollarNames | ||||||||
| #' @export | ||||||||
| .DollarNames.ggproto <- function(x, pattern = "") { | ||||||||
| methods <- ls(envir = x) | ||||||||
| if ("super" %in% methods) { | ||||||||
| methods <- setdiff(methods, "super") | ||||||||
| methods <- union(methods, Recall(x$super())) | ||||||||
| } | ||||||||
| if (identical(pattern, "")) { | ||||||||
| methods | ||||||||
| } else { | ||||||||
| grep(pattern, methods, value = TRUE) | ||||||||
| } | ||||||||
| } | ||||||||
| #' @export | ||||||||
| `$.ggproto` <- function(x, name) { | ||||||||
| res <- fetch_ggproto(x, name) | ||||||||
| if (!is.function(res)) { | ||||||||
| return(res) | ||||||||
| } | ||||||||
| make_proto_method(x, res) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| `$.ggproto_parent` <- function(x, name) { | ||||||||
| res <- fetch_ggproto(.subset2(x, "parent"), name) | ||||||||
| if (!is.function(res)) { | ||||||||
| return(res) | ||||||||
| } | ||||||||
| make_proto_method(.subset2(x, "self"), res) | ||||||||
| } | ||||||||
| make_proto_method <- function(self, f) { | ||||||||
| args <- formals(f) | ||||||||
| # is.null is a fast path for a common case; the %in% check is slower but also | ||||||||
| # catches the case where there's a `self = NULL` argument. | ||||||||
| has_self <- !is.null(args[["self"]]) || "self" %in% names(args) | ||||||||
| if (has_self) { | ||||||||
| fun <- function(...) f(..., self = self) | ||||||||
| } else { | ||||||||
| fun <- function(...) f(...) | ||||||||
| } | ||||||||
| class(fun) <- "ggproto_method" | ||||||||
| fun | ||||||||
| } | ||||||||
| #' @export | ||||||||
| `[[.ggproto` <- `$.ggproto` | ||||||||
| #' Convert a ggproto object to a list | ||||||||
| #' | ||||||||
| #' This will not include the object's `super` member. | ||||||||
| #' | ||||||||
| #' @param x A ggproto object to convert to a list. | ||||||||
| #' @param inherit If `TRUE` (the default), flatten all inherited items into | ||||||||
| #' the returned list. If `FALSE`, do not include any inherited items. | ||||||||
| #' @inheritDotParams base::as.list.environment -x | ||||||||
| #' @export | ||||||||
| #' @keywords internal | ||||||||
| as.list.ggproto <- function(x, inherit = TRUE, ...) { | ||||||||
| res <- list() | ||||||||
| if (inherit) { | ||||||||
| if (is.function(x$super)) { | ||||||||
| res <- as.list(x$super()) | ||||||||
| } | ||||||||
| } | ||||||||
| current <- as.list.environment(x, ...) | ||||||||
| res[names(current)] <- current | ||||||||
| res$super <- NULL | ||||||||
| res | ||||||||
| } | ||||||||
| #' Format or print a ggproto object | ||||||||
| #' | ||||||||
| #' If a ggproto object has a `$print` method, this will call that method. | ||||||||
| #' Otherwise, it will print out the members of the object, and optionally, the | ||||||||
| #' members of the inherited objects. | ||||||||
| #' | ||||||||
| #' @param x A ggproto object to print. | ||||||||
| #' @param flat If `TRUE` (the default), show a flattened list of all local | ||||||||
| #' and inherited members. If `FALSE`, show the inheritance hierarchy. | ||||||||
| #' @param ... If the ggproto object has a `print` method, further arguments | ||||||||
| #' will be passed to it. Otherwise, these arguments are unused. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' Dog <- ggproto( | ||||||||
| #' print = function(self, n) { | ||||||||
| #' cat("Woof!\n") | ||||||||
| #' } | ||||||||
| #' ) | ||||||||
| #' Dog | ||||||||
| #' cat(format(Dog), "\n") | ||||||||
| print.ggproto <- function(x, ..., flat = TRUE) { | ||||||||
| if (is.function(x$print)) { | ||||||||
| x$print(...) | ||||||||
| } else { | ||||||||
| cat(format(x, flat = flat), "\n", sep = "") | ||||||||
| invisible(x) | ||||||||
| } | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname print.ggproto | ||||||||
| format.ggproto <- function(x, ..., flat = TRUE) { | ||||||||
| classes_str <- function(obj) { | ||||||||
| classes <- setdiff(class(obj), "ggproto") | ||||||||
| if (length(classes) == 0) | ||||||||
| return("") | ||||||||
| paste0(": Class ", paste(classes, collapse = ', ')) | ||||||||
| } | ||||||||
| # Get a flat list if requested | ||||||||
| if (flat) { | ||||||||
| objs <- as.list(x, inherit = TRUE) | ||||||||
| } else { | ||||||||
| objs <- x | ||||||||
| } | ||||||||
| str <- paste0( | ||||||||
| "<ggproto object", classes_str(x), ">\n", | ||||||||
| indent(object_summaries(objs, flat = flat), 4) | ||||||||
| ) | ||||||||
| if (flat && is.function(x$super)) { | ||||||||
| str <- paste0( | ||||||||
| str, "\n", | ||||||||
| indent( | ||||||||
| paste0("super: ", " <ggproto object", classes_str(x$super()), ">"), | ||||||||
| 4 | ||||||||
| ) | ||||||||
| ) | ||||||||
| } | ||||||||
| str | ||||||||
| } | ||||||||
| # Return a summary string of the items of a list or environment | ||||||||
| # x must be a list or environment | ||||||||
| object_summaries <- function(x, exclude = NULL, flat = TRUE) { | ||||||||
| if (length(x) == 0) | ||||||||
| return(NULL) | ||||||||
| if (is.list(x)) | ||||||||
| obj_names <- sort(names(x)) | ||||||||
| else if (is.environment(x)) | ||||||||
| obj_names <- ls(x, all.names = TRUE) | ||||||||
| obj_names <- setdiff(obj_names, exclude) | ||||||||
| values <- vapply(obj_names, function(name) { | ||||||||
| obj <- x[[name]] | ||||||||
| if (is.function(obj)) "function" | ||||||||
| else if (is.ggproto(obj)) format(obj, flat = flat) | ||||||||
| else if (is.environment(obj)) "environment" | ||||||||
| else if (is.null(obj)) "NULL" | ||||||||
| else if (is.atomic(obj)) trim(paste(as.character(obj), collapse = " ")) | ||||||||
| else paste(class(obj), collapse = ", ") | ||||||||
| }, FUN.VALUE = character(1)) | ||||||||
| paste0(obj_names, ": ", values, sep = "", collapse = "\n") | ||||||||
| } | ||||||||
| # Given a string, indent every line by some number of spaces. | ||||||||
| # The exception is to not add spaces after a trailing \n. | ||||||||
| indent <- function(str, indent = 0) { | ||||||||
| gsub("(\\n|^)(?!$)", | ||||||||
| paste0("\\1", paste(rep(" ", indent), collapse = "")), | ||||||||
| str, | ||||||||
| perl = TRUE | ||||||||
| ) | ||||||||
| } | ||||||||
| # Trim a string to n characters; if it's longer than n, add " ..." to the end | ||||||||
| trim <- function(str, n = 60) { | ||||||||
| if (nchar(str) > n) paste(substr(str, 1, 56), "...") | ||||||||
| else str | ||||||||
| } | ||||||||
| #' @export | ||||||||
| print.ggproto_method <- function(x, ...) { | ||||||||
| cat(format(x), sep = "") | ||||||||
| } | ||||||||
| #' @export | ||||||||
| format.ggproto_method <- function(x, ...) { | ||||||||
| # Given a function, return a string from srcref if present. If not present, | ||||||||
| # paste the deparsed lines of code together. | ||||||||
| format_fun <- function(fn) { | ||||||||
| srcref <- attr(fn, "srcref", exact = TRUE) | ||||||||
| if (is.null(srcref)) | ||||||||
| return(paste(format(fn), collapse = "\n")) | ||||||||
| paste(as.character(srcref), collapse = "\n") | ||||||||
| } | ||||||||
| x <- unclass(x) | ||||||||
| paste0( | ||||||||
| "<ggproto method>", | ||||||||
| "\n <Wrapper function>\n ", format_fun(x), | ||||||||
| "\n\n <Inner function (f)>\n ", format_fun(environment(x)$f) | ||||||||
| ) | ||||||||
| } | ||||||||
| # proto2 TODO: better way of getting formals for self$draw | ||||||||
| ggproto_formals <- function(x) formals(environment(x)$f) | ||||||||
| ggplot2/R/geom-.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' @include legend-draw.r | ||||||||
| NULL | ||||||||
| #' @section Geoms: | ||||||||
| #' | ||||||||
| #' All `geom_*` functions (like `geom_point`) return a layer that | ||||||||
| #' contains a `Geom*` object (like `GeomPoint`). The `Geom*` | ||||||||
| #' object is responsible for rendering the data in the plot. | ||||||||
| #' | ||||||||
| #' Each of the `Geom*` objects is a [ggproto()] object, descended | ||||||||
| #' from the top-level `Geom`, and each implements various methods and | ||||||||
| #' fields. | ||||||||
| #' | ||||||||
| #' Compared to `Stat` and `Position`, `Geom` is a little | ||||||||
| #' different because the execution of the setup and compute functions is | ||||||||
| #' split up. `setup_data` runs before position adjustments, and | ||||||||
| #' `draw_layer` is not run until render time, much later. This | ||||||||
| #' means there is no `setup_params` because it's hard to communicate | ||||||||
| #' the changes. | ||||||||
| #' | ||||||||
| #' To create a new type of Geom object, you typically will want to | ||||||||
| #' override one or more of the following: | ||||||||
| #' | ||||||||
| #' - Either `draw_panel(self, data, panel_params, coord)` or | ||||||||
| #' `draw_group(self, data, panel_params, coord)`. `draw_panel` is | ||||||||
| #' called once per panel, `draw_group` is called once per group. | ||||||||
| #' | ||||||||
| #' Use `draw_panel` if each row in the data represents a | ||||||||
| #' single element. Use `draw_group` if each group represents | ||||||||
| #' an element (e.g. a smooth, a violin). | ||||||||
| #' | ||||||||
| #' `data` is a data frame of scaled aesthetics. | ||||||||
| #' | ||||||||
| #' `panel_params` is a set of per-panel parameters for the | ||||||||
| #' `coord`. Generally, you should consider `panel_params` | ||||||||
| #' to be an opaque data structure that you pass along whenever you call | ||||||||
| #' a coord method. | ||||||||
| #' | ||||||||
| #' You must always call `coord$transform(data, panel_params)` to | ||||||||
| #' get the (position) scaled data for plotting. To work with | ||||||||
| #' non-linear coordinate systems, you typically need to convert into a | ||||||||
| #' primitive geom (e.g. point, path or polygon), and then pass on to the | ||||||||
| #' corresponding draw method for munching. | ||||||||
| #' | ||||||||
| #' Must return a grob. Use [zeroGrob()] if there's nothing to | ||||||||
| #' draw. | ||||||||
| #' - `draw_key`: Renders a single legend key. | ||||||||
| #' - `required_aes`: A character vector of aesthetics needed to | ||||||||
| #' render the geom. | ||||||||
| #' - `default_aes`: A list (generated by [aes()] of | ||||||||
| #' default values for aesthetics. | ||||||||
| #' - `setup_data`: Converts width and height to xmin and xmax, | ||||||||
| #' and ymin and ymax values. It can potentially set other values as well. | ||||||||
| #' @rdname ggplot2-ggproto | ||||||||
| #' @format NULL | ||||||||
| #' @usage NULL | ||||||||
| #' @export | ||||||||
| Geom <- ggproto("Geom", | ||||||||
| required_aes = character(), | ||||||||
| non_missing_aes = character(), | ||||||||
| optional_aes = character(), | ||||||||
| default_aes = aes(), | ||||||||
| draw_key = draw_key_point, | ||||||||
| handle_na = function(self, data, params) { | ||||||||
| remove_missing(data, params$na.rm, | ||||||||
| c(self$required_aes, self$non_missing_aes), | ||||||||
| snake_class(self) | ||||||||
| ) | ||||||||
| }, | ||||||||
| draw_layer = function(self, data, params, layout, coord) { | ||||||||
| if (empty(data)) { | ||||||||
| n <- if (is.factor(data$PANEL)) nlevels(data$PANEL) else 1L | ||||||||
| return(rep(list(zeroGrob()), n)) | ||||||||
| } | ||||||||
| # Trim off extra parameters | ||||||||
| params <- params[intersect(names(params), self$parameters())] | ||||||||
| args <- c(list(quote(data), quote(panel_params), quote(coord)), params) | ||||||||
| plyr::dlply(data, "PANEL", function(data) { | ||||||||
| if (empty(data)) return(zeroGrob()) | ||||||||
| panel_params <- layout$panel_params[[data$PANEL[1]]] | ||||||||
| do.call(self$draw_panel, args) | ||||||||
| }, .drop = FALSE) | ||||||||
| }, | ||||||||
| draw_panel = function(self, data, panel_params, coord, ...) { | ||||||||
| groups <- split(data, factor(data$group)) | ||||||||
| grobs <- lapply(groups, function(group) { | ||||||||
| self$draw_group(group, panel_params, coord, ...) | ||||||||
| }) | ||||||||
| ggname(snake_class(self), gTree( | ||||||||
| children = do.call("gList", grobs) | ||||||||
| )) | ||||||||
| }, | ||||||||
| draw_group = function(self, data, panel_params, coord) { | ||||||||
| stop("Not implemented") | ||||||||
| }, | ||||||||
| setup_data = function(data, params) data, | ||||||||
| # Combine data with defaults and set aesthetics from parameters | ||||||||
| use_defaults = function(self, data, params = list()) { | ||||||||
| # Fill in missing aesthetics with their defaults | ||||||||
| missing_aes <- setdiff(names(self$default_aes), names(data)) | ||||||||
| missing_eval <- lapply(self$default_aes[missing_aes], rlang::eval_tidy) | ||||||||
| # Needed for geoms with defaults set to NULL (e.g. GeomSf) | ||||||||
| missing_eval <- compact(missing_eval) | ||||||||
| if (empty(data)) { | ||||||||
| data <- as_gg_data_frame(missing_eval) | ||||||||
| } else { | ||||||||
| data[names(missing_eval)] <- missing_eval | ||||||||
| } | ||||||||
| # Override mappings with params | ||||||||
| aes_params <- intersect(self$aesthetics(), names(params)) | ||||||||
| check_aesthetics(params[aes_params], nrow(data)) | ||||||||
| data[aes_params] <- params[aes_params] | ||||||||
| data | ||||||||
| }, | ||||||||
| # Most parameters for the geom are taken automatically from draw_panel() or | ||||||||
| # draw_groups(). However, some additional parameters may be needed | ||||||||
| # for setup_data() or handle_na(). These can not be imputed automatically, | ||||||||
| # so the slightly hacky "extra_params" field is used instead. By | ||||||||
| # default it contains `na.rm` | ||||||||
| extra_params = c("na.rm"), | ||||||||
| parameters = function(self, extra = FALSE) { | ||||||||
| # Look first in draw_panel. If it contains ... then look in draw groups | ||||||||
| panel_args <- names(ggproto_formals(self$draw_panel)) | ||||||||
| group_args <- names(ggproto_formals(self$draw_group)) | ||||||||
| args <- if ("..." %in% panel_args) group_args else panel_args | ||||||||
| # Remove arguments of defaults | ||||||||
| args <- setdiff(args, names(ggproto_formals(Geom$draw_group))) | ||||||||
| if (extra) { | ||||||||
| args <- union(args, self$extra_params) | ||||||||
| } | ||||||||
| args | ||||||||
| }, | ||||||||
| aesthetics = function(self) { | ||||||||
| c(union(self$required_aes, names(self$default_aes)), self$optional_aes, "group") | ||||||||
| } | ||||||||
| ) | ||||||||
| #' Graphical units | ||||||||
| #' | ||||||||
| #' Multiply size in mm by these constants in order to convert to the units | ||||||||
| #' that grid uses internally for `lwd` and `fontsize`. | ||||||||
| #' | ||||||||
| #' @name graphical-units | ||||||||
| #' @keywords internal | ||||||||
| #' @aliases NULL | ||||||||
| NULL | ||||||||
| #' @export | ||||||||
| #' @rdname graphical-units | ||||||||
| .pt <- 72.27 / 25.4 | ||||||||
| #' @export | ||||||||
| #' @rdname graphical-units | ||||||||
| .stroke <- 96 / 25.4 | ||||||||
| check_aesthetics <- function(x, n) { | ||||||||
| ns <- vapply(x, length, numeric(1)) | ||||||||
| good <- ns == 1L | ns == n | ||||||||
| if (all(good)) { | ||||||||
| return() | ||||||||
| } | ||||||||
| stop( | ||||||||
| "Aesthetics must be either length 1 or the same as the data (", n, "): ", | ||||||||
| paste(names(which(!good)), collapse = ", "), | ||||||||
| call. = FALSE | ||||||||
| ) | ||||||||
| } | ||||||||
| ggplot2/R/layer.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Create a new layer | ||||||||
| #' | ||||||||
| #' A layer is a combination of data, stat and geom with a potential position | ||||||||
| #' adjustment. Usually layers are created using `geom_*` or `stat_*` | ||||||||
| #' calls but it can also be created directly using this function. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @inheritParams geom_point | ||||||||
| #' @param mapping Set of aesthetic mappings created by [aes()] or | ||||||||
| #' [aes_()]. If specified and `inherit.aes = TRUE` (the | ||||||||
| #' default), it is combined with the default mapping at the top level of the | ||||||||
| #' plot. You must supply `mapping` if there is no plot mapping. | ||||||||
| #' @param data The data to be displayed in this layer. There are three | ||||||||
| #' options: | ||||||||
| #' | ||||||||
| #' If `NULL`, the default, the data is inherited from the plot | ||||||||
| #' data as specified in the call to [ggplot()]. | ||||||||
| #' | ||||||||
| #' A `data.frame`, or other object, will override the plot | ||||||||
| #' data. All objects will be fortified to produce a data frame. See | ||||||||
| #' [fortify()] for which variables will be created. | ||||||||
| #' | ||||||||
| #' A `function` will be called with a single argument, | ||||||||
| #' the plot data. The return value must be a `data.frame`, and | ||||||||
| #' will be used as the layer data. | ||||||||
| #' @param geom The geometric object to use display the data | ||||||||
| #' @param stat The statistical transformation to use on the data for this | ||||||||
| #' layer, as a string. | ||||||||
| #' @param position Position adjustment, either as a string, or the result of | ||||||||
| #' a call to a position adjustment function. | ||||||||
| #' @param show.legend logical. Should this layer be included in the legends? | ||||||||
| #' `NA`, the default, includes if any aesthetics are mapped. | ||||||||
| #' `FALSE` never includes, and `TRUE` always includes. | ||||||||
| #' It can also be a named logical vector to finely select the aesthetics to | ||||||||
| #' display. | ||||||||
| #' @param inherit.aes If `FALSE`, overrides the default aesthetics, | ||||||||
| #' rather than combining with them. This is most useful for helper functions | ||||||||
| #' that define both data and aesthetics and shouldn't inherit behaviour from | ||||||||
| #' the default plot specification, e.g. [borders()]. | ||||||||
| #' @param check.aes,check.param If `TRUE`, the default, will check that | ||||||||
| #' supplied parameters and aesthetics are understood by the `geom` or | ||||||||
| #' `stat`. Use `FALSE` to suppress the checks. | ||||||||
| #' @param params Additional parameters to the `geom` and `stat`. | ||||||||
| #' @keywords internal | ||||||||
| #' @examples | ||||||||
| #' # geom calls are just a short cut for layer | ||||||||
| #' ggplot(mpg, aes(displ, hwy)) + geom_point() | ||||||||
| #' # shortcut for | ||||||||
| #' ggplot(mpg, aes(displ, hwy)) + | ||||||||
| #' layer(geom = "point", stat = "identity", position = "identity", | ||||||||
| #' params = list(na.rm = FALSE) | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' # use a function as data to plot a subset of global data | ||||||||
| #' ggplot(mpg, aes(displ, hwy)) + | ||||||||
| #' layer(geom = "point", stat = "identity", position = "identity", | ||||||||
| #' data = head, params = list(na.rm = FALSE) | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| layer <- function(geom = NULL, stat = NULL, | ||||||||
| data = NULL, mapping = NULL, | ||||||||
| position = NULL, params = list(), | ||||||||
| inherit.aes = TRUE, check.aes = TRUE, check.param = TRUE, | ||||||||
| show.legend = NA) { | ||||||||
| if (is.null(geom)) | ||||||||
| stop("Attempted to create layer with no geom.", call. = FALSE) | ||||||||
| if (is.null(stat)) | ||||||||
| stop("Attempted to create layer with no stat.", call. = FALSE) | ||||||||
| if (is.null(position)) | ||||||||
| stop("Attempted to create layer with no position.", call. = FALSE) | ||||||||
| # Handle show_guide/show.legend | ||||||||
| if (!is.null(params$show_guide)) { | ||||||||
| warning("`show_guide` has been deprecated. Please use `show.legend` instead.", | ||||||||
| call. = FALSE) | ||||||||
| show.legend <- params$show_guide | ||||||||
| params$show_guide <- NULL | ||||||||
| } | ||||||||
| if (!is.logical(show.legend)) { | ||||||||
| warning("`show.legend` must be a logical vector.", call. = FALSE) | ||||||||
| show.legend <- FALSE | ||||||||
| } | ||||||||
| # we validate mapping before data because in geoms and stats | ||||||||
| # the mapping is listed before the data argument; this causes | ||||||||
| # less confusing error messages when layers are accidentally | ||||||||
| # piped into each other | ||||||||
| if (!is.null(mapping)) { | ||||||||
| mapping <- validate_mapping(mapping) | ||||||||
| } | ||||||||
| data <- fortify(data) | ||||||||
| geom <- check_subclass(geom, "Geom", env = parent.frame()) | ||||||||
| stat <- check_subclass(stat, "Stat", env = parent.frame()) | ||||||||
| position <- check_subclass(position, "Position", env = parent.frame()) | ||||||||
| # Special case for na.rm parameter needed by all layers | ||||||||
| if (is.null(params$na.rm)) { | ||||||||
| params$na.rm <- FALSE | ||||||||
| } | ||||||||
| # Split up params between aesthetics, geom, and stat | ||||||||
| params <- rename_aes(params) | ||||||||
| aes_params <- params[intersect(names(params), geom$aesthetics())] | ||||||||
| geom_params <- params[intersect(names(params), geom$parameters(TRUE))] | ||||||||
| stat_params <- params[intersect(names(params), stat$parameters(TRUE))] | ||||||||
| all <- c(geom$parameters(TRUE), stat$parameters(TRUE), geom$aesthetics()) | ||||||||
| # Warn about extra params and aesthetics | ||||||||
| extra_param <- setdiff(names(params), all) | ||||||||
| if (check.param && length(extra_param) > 0) { | ||||||||
| warning( | ||||||||
| "Ignoring unknown parameters: ", paste(extra_param, collapse = ", "), | ||||||||
| call. = FALSE, | ||||||||
| immediate. = TRUE | ||||||||
| ) | ||||||||
| } | ||||||||
| extra_aes <- setdiff( | ||||||||
| mapped_aesthetics(mapping), | ||||||||
| c(geom$aesthetics(), stat$aesthetics()) | ||||||||
| ) | ||||||||
| if (check.aes && length(extra_aes) > 0) { | ||||||||
| warning( | ||||||||
| "Ignoring unknown aesthetics: ", paste(extra_aes, collapse = ", "), | ||||||||
| call. = FALSE, | ||||||||
| immediate. = TRUE | ||||||||
| ) | ||||||||
| } | ||||||||
| ggproto("LayerInstance", Layer, | ||||||||
| geom = geom, | ||||||||
| geom_params = geom_params, | ||||||||
| stat = stat, | ||||||||
| stat_params = stat_params, | ||||||||
| data = data, | ||||||||
| mapping = mapping, | ||||||||
| aes_params = aes_params, | ||||||||
| position = position, | ||||||||
| inherit.aes = inherit.aes, | ||||||||
| show.legend = show.legend | ||||||||
| ) | ||||||||
| } | ||||||||
| validate_mapping <- function(mapping) { | ||||||||
| if (!inherits(mapping, "uneval")) { | ||||||||
| msg <- paste0("`mapping` must be created by `aes()`") | ||||||||
| if (inherits(mapping, "ggplot")) { | ||||||||
| msg <- paste0( | ||||||||
| msg, "\n", | ||||||||
| "Did you use %>% instead of +?" | ||||||||
| ) | ||||||||
| } | ||||||||
| stop(msg, call. = FALSE) | ||||||||
| } | ||||||||
| # For backward compatibility with pre-tidy-eval layers | ||||||||
| new_aes(mapping) | ||||||||
| } | ||||||||
| Layer <- ggproto("Layer", NULL, | ||||||||
| geom = NULL, | ||||||||
| geom_params = NULL, | ||||||||
| stat = NULL, | ||||||||
| stat_params = NULL, | ||||||||
| data = NULL, | ||||||||
| aes_params = NULL, | ||||||||
| mapping = NULL, | ||||||||
| position = NULL, | ||||||||
| inherit.aes = FALSE, | ||||||||
| print = function(self) { | ||||||||
| if (!is.null(self$mapping)) { | ||||||||
| cat("mapping:", clist(self$mapping), "\n") | ||||||||
| } | ||||||||
| cat(snakeize(class(self$geom)[[1]]), ": ", clist(self$geom_params), "\n", | ||||||||
| sep = "") | ||||||||
| cat(snakeize(class(self$stat)[[1]]), ": ", clist(self$stat_params), "\n", | ||||||||
| sep = "") | ||||||||
| cat(snakeize(class(self$position)[[1]]), "\n") | ||||||||
| }, | ||||||||
| layer_data = function(self, plot_data) { | ||||||||
| if (is.waive(self$data)) { | ||||||||
| plot_data | ||||||||
| } else if (is.function(self$data)) { | ||||||||
| data <- self$data(plot_data) | ||||||||
| if (!is.data.frame(data)) { | ||||||||
| stop("Data function must return a data.frame", call. = FALSE) | ||||||||
| } | ||||||||
| data | ||||||||
| } else { | ||||||||
| self$data | ||||||||
| } | ||||||||
| }, | ||||||||
| compute_aesthetics = function(self, data, plot) { | ||||||||
| # For annotation geoms, it is useful to be able to ignore the default aes | ||||||||
| if (self$inherit.aes) { | ||||||||
| aesthetics <- defaults(self$mapping, plot$mapping) | ||||||||
| } else { | ||||||||
| aesthetics <- self$mapping | ||||||||
| } | ||||||||
| # Drop aesthetics that are set or calculated | ||||||||
| set <- names(aesthetics) %in% names(self$aes_params) | ||||||||
| calculated <- is_calculated_aes(aesthetics) | ||||||||
| aesthetics <- aesthetics[!set & !calculated] | ||||||||
| # Override grouping if set in layer | ||||||||
| if (!is.null(self$geom_params$group)) { | ||||||||
| aesthetics[["group"]] <- self$aes_params$group | ||||||||
| } | ||||||||
| scales_add_defaults(plot$scales, data, aesthetics, plot$plot_env) | ||||||||
| # Evaluate and check aesthetics | ||||||||
| aesthetics <- compact(aesthetics) | ||||||||
| evaled <- lapply(aesthetics, rlang::eval_tidy, data = data) | ||||||||
| n <- nrow(data) | ||||||||
| if (n == 0) { | ||||||||
| # No data, so look at longest evaluated aesthetic | ||||||||
| if (length(evaled) == 0) { | ||||||||
| n <- 0 | ||||||||
| } else { | ||||||||
| n <- max(vapply(evaled, length, integer(1))) | ||||||||
| } | ||||||||
| } | ||||||||
| check_aesthetics(evaled, n) | ||||||||
| # Set special group and panel vars | ||||||||
| if (empty(data) && n > 0) { | ||||||||
| evaled$PANEL <- 1 | ||||||||
| } else { | ||||||||
| evaled$PANEL <- data$PANEL | ||||||||
| } | ||||||||
| evaled <- lapply(evaled, unname) | ||||||||
| evaled <- as_gg_data_frame(evaled) | ||||||||
| evaled <- add_group(evaled) | ||||||||
| evaled | ||||||||
| }, | ||||||||
| compute_statistic = function(self, data, layout) { | ||||||||
| if (empty(data)) | ||||||||
| return(new_data_frame()) | ||||||||
| params <- self$stat$setup_params(data, self$stat_params) | ||||||||
| data <- self$stat$setup_data(data, params) | ||||||||
| self$stat$compute_layer(data, params, layout) | ||||||||
| }, | ||||||||
| map_statistic = function(self, data, plot) { | ||||||||
| if (empty(data)) return(new_data_frame()) | ||||||||
| # Assemble aesthetics from layer, plot and stat mappings | ||||||||
| aesthetics <- self$mapping | ||||||||
| if (self$inherit.aes) { | ||||||||
| aesthetics <- defaults(aesthetics, plot$mapping) | ||||||||
| } | ||||||||
| aesthetics <- defaults(aesthetics, self$stat$default_aes) | ||||||||
| aesthetics <- compact(aesthetics) | ||||||||
| new <- strip_dots(aesthetics[is_calculated_aes(aesthetics)]) | ||||||||
| if (length(new) == 0) return(data) | ||||||||
| # Add map stat output to aesthetics | ||||||||
| env <- new.env(parent = baseenv()) | ||||||||
| env$stat <- stat | ||||||||
| stat_data <- plyr::quickdf(lapply(new, rlang::eval_tidy, data, env)) | ||||||||
| names(stat_data) <- names(new) | ||||||||
| # Add any new scales, if needed | ||||||||
| scales_add_defaults(plot$scales, data, new, plot$plot_env) | ||||||||
| # Transform the values, if the scale say it's ok | ||||||||
| # (see stat_spoke for one exception) | ||||||||
| if (self$stat$retransform) { | ||||||||
| stat_data <- scales_transform_df(plot$scales, stat_data) | ||||||||
| } | ||||||||
| cunion(stat_data, data) | ||||||||
| }, | ||||||||
| compute_geom_1 = function(self, data) { | ||||||||
| if (empty(data)) return(new_data_frame()) | ||||||||
| check_required_aesthetics( | ||||||||
| self$geom$required_aes, | ||||||||
| c(names(data), names(self$aes_params)), | ||||||||
| snake_class(self$geom) | ||||||||
| ) | ||||||||
| self$geom$setup_data(data, c(self$geom_params, self$aes_params)) | ||||||||
| }, | ||||||||
| compute_position = function(self, data, layout) { | ||||||||
| if (empty(data)) return(new_data_frame()) | ||||||||
| params <- self$position$setup_params(data) | ||||||||
| data <- self$position$setup_data(data, params) | ||||||||
| self$position$compute_layer(data, params, layout) | ||||||||
| }, | ||||||||
| compute_geom_2 = function(self, data) { | ||||||||
| # Combine aesthetics, defaults, & params | ||||||||
| if (empty(data)) return(data) | ||||||||
| self$geom$use_defaults(data, self$aes_params) | ||||||||
| }, | ||||||||
| finish_statistics = function(self, data) { | ||||||||
| self$stat$finish_layer(data, self$stat_params) | ||||||||
| }, | ||||||||
| draw_geom = function(self, data, layout) { | ||||||||
| if (empty(data)) { | ||||||||
| n <- nrow(layout$layout) | ||||||||
| return(rep(list(zeroGrob()), n)) | ||||||||
| } | ||||||||
| data <- self$geom$handle_na(data, self$geom_params) | ||||||||
| self$geom$draw_layer(data, self$geom_params, layout, layout$coord) | ||||||||
| } | ||||||||
| ) | ||||||||
| is.layer <- function(x) inherits(x, "Layer") | ||||||||
| check_subclass <- function(x, subclass, | ||||||||
| argname = tolower(subclass), | ||||||||
| env = parent.frame()) { | ||||||||
| if (inherits(x, subclass)) { | ||||||||
| x | ||||||||
| } else if (is.character(x) && length(x) == 1) { | ||||||||
| name <- paste0(subclass, camelize(x, first = TRUE)) | ||||||||
| obj <- find_global(name, env = env) | ||||||||
| if (is.null(obj) || !inherits(obj, subclass)) { | ||||||||
| stop("Can't find `", argname, "` called \"", x, "\"", call. = FALSE) | ||||||||
| } else { | ||||||||
| obj | ||||||||
| } | ||||||||
| } else { | ||||||||
| stop( | ||||||||
| "`", argname, "` must be either a string or a ", subclass, " object, ", | ||||||||
| "not ", obj_desc(x), | ||||||||
| call. = FALSE | ||||||||
| ) | ||||||||
| } | ||||||||
| } | ||||||||
| obj_desc <- function(x) { | ||||||||
| if (isS4(x)) { | ||||||||
| paste0("an S4 object with class ", class(x)[[1]]) | ||||||||
| } else if (is.object(x)) { | ||||||||
| if (is.data.frame(x)) { | ||||||||
| "a data frame" | ||||||||
| } else if (is.factor(x)) { | ||||||||
| "a factor" | ||||||||
| } else { | ||||||||
| paste0("an S3 object with class ", paste(class(x), collapse = "/")) | ||||||||
| } | ||||||||
| } else { | ||||||||
| switch(typeof(x), | ||||||||
| "NULL" = "a NULL", | ||||||||
| character = "a character vector", | ||||||||
| integer = "an integer vector", | ||||||||
| logical = "a logical vector", | ||||||||
| double = "a numeric vector", | ||||||||
| list = "a list", | ||||||||
| closure = "a function", | ||||||||
| paste0("a base object of type", typeof(x)) | ||||||||
| ) | ||||||||
| } | ||||||||
| } | ||||||||
| ggplot2/R/plot-build.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Build ggplot for rendering. | ||||||||
| #' | ||||||||
| #' `ggplot_build` takes the plot object, and performs all steps necessary | ||||||||
| #' to produce an object that can be rendered. This function outputs two pieces: | ||||||||
| #' a list of data frames (one for each layer), and a panel object, which | ||||||||
| #' contain all information about axis limits, breaks etc. | ||||||||
| #' | ||||||||
| #' `layer_data`, `layer_grob`, and `layer_scales` are helper | ||||||||
| #' functions that returns the data, grob, or scales associated with a given | ||||||||
| #' layer. These are useful for tests. | ||||||||
| #' | ||||||||
| #' @param plot ggplot object | ||||||||
| #' @seealso [print.ggplot()] and [benchplot()] for | ||||||||
| #' functions that contain the complete set of steps for generating | ||||||||
| #' a ggplot2 plot. | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| ggplot_build <- function(plot) { | ||||||||
| UseMethod('ggplot_build') | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_build.ggplot <- function(plot) { | ||||||||
| plot <- plot_clone(plot) | ||||||||
| if (length(plot$layers) == 0) { | ||||||||
| plot <- plot + geom_blank() | ||||||||
| } | ||||||||
| layers <- plot$layers | ||||||||
| layer_data <- lapply(layers, function(y) y$layer_data(plot$data)) | ||||||||
| scales <- plot$scales | ||||||||
| # Apply function to layer and matching data | ||||||||
| by_layer <- function(f) { | ||||||||
| out <- vector("list", length(data)) | ||||||||
| for (i in seq_along(data)) { | ||||||||
| out[[i]] <- f(l = layers[[i]], d = data[[i]]) | ||||||||
| } | ||||||||
| out | ||||||||
| } | ||||||||
| # Initialise panels, add extra data for margins & missing faceting | ||||||||
| # variables, and add on a PANEL variable to data | ||||||||
| layout <- create_layout(plot$facet, plot$coordinates) | ||||||||
| data <- layout$setup(layer_data, plot$data, plot$plot_env) | ||||||||
| # Compute aesthetics to produce data with generalised variable names | ||||||||
| data <- by_layer(function(l, d) l$compute_aesthetics(d, plot)) | ||||||||
| # Transform all scales | ||||||||
| data <- lapply(data, scales_transform_df, scales = scales) | ||||||||
| # Map and train positions so that statistics have access to ranges | ||||||||
| # and all positions are numeric | ||||||||
| scale_x <- function() scales$get_scales("x") | ||||||||
| scale_y <- function() scales$get_scales("y") | ||||||||
| layout$train_position(data, scale_x(), scale_y()) | ||||||||
| data <- layout$map_position(data) | ||||||||
| # Apply and map statistics | ||||||||
| data <- by_layer(function(l, d) l$compute_statistic(d, layout)) | ||||||||
| data <- by_layer(function(l, d) l$map_statistic(d, plot)) | ||||||||
| # Make sure missing (but required) aesthetics are added | ||||||||
| scales_add_missing(plot, c("x", "y"), plot$plot_env) | ||||||||
| # Reparameterise geoms from (e.g.) y and width to ymin and ymax | ||||||||
| data <- by_layer(function(l, d) l$compute_geom_1(d)) | ||||||||
| # Apply position adjustments | ||||||||
| data <- by_layer(function(l, d) l$compute_position(d, layout)) | ||||||||
| # Reset position scales, then re-train and map. This ensures that facets | ||||||||
| # have control over the range of a plot: is it generated from what is | ||||||||
| # displayed, or does it include the range of underlying data | ||||||||
| layout$reset_scales() | ||||||||
| layout$train_position(data, scale_x(), scale_y()) | ||||||||
| layout$setup_panel_params() | ||||||||
| data <- layout$map_position(data) | ||||||||
| # Train and map non-position scales | ||||||||
| npscales <- scales$non_position_scales() | ||||||||
| if (npscales$n() > 0) { | ||||||||
| lapply(data, scales_train_df, scales = npscales) | ||||||||
| data <- lapply(data, scales_map_df, scales = npscales) | ||||||||
| } | ||||||||
| # Fill in defaults etc. | ||||||||
| data <- by_layer(function(l, d) l$compute_geom_2(d)) | ||||||||
| # Let layer stat have a final say before rendering | ||||||||
| data <- by_layer(function(l, d) l$finish_statistics(d)) | ||||||||
| # Let Layout modify data before rendering | ||||||||
| data <- layout$finish_data(data) | ||||||||
| structure( | ||||||||
| list(data = data, layout = layout, plot = plot), | ||||||||
| class = "ggplot_built" | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname ggplot_build | ||||||||
| layer_data <- function(plot, i = 1L) { | ||||||||
| ggplot_build(plot)$data[[i]] | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname ggplot_build | ||||||||
| layer_scales <- function(plot, i = 1L, j = 1L) { | ||||||||
| b <- ggplot_build(plot) | ||||||||
| layout <- b$layout$layout | ||||||||
| selected <- layout[layout$ROW == i & layout$COL == j, , drop = FALSE] | ||||||||
| list( | ||||||||
| x = b$layout$panel_scales_x[[selected$SCALE_X]], | ||||||||
| y = b$layout$panel_scales_y[[selected$SCALE_Y]] | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname ggplot_build | ||||||||
| layer_grob <- function(plot, i = 1L) { | ||||||||
| b <- ggplot_build(plot) | ||||||||
| b$plot$layers[[i]]$draw_geom(b$data[[i]], b$layout) | ||||||||
| } | ||||||||
| #' Build a plot with all the usual bits and pieces. | ||||||||
| #' | ||||||||
| #' This function builds all grobs necessary for displaying the plot, and | ||||||||
| #' stores them in a special data structure called a [gtable()]. | ||||||||
| #' This object is amenable to programmatic manipulation, should you want | ||||||||
| #' to (e.g.) make the legend box 2 cm wide, or combine multiple plots into | ||||||||
| #' a single display, preserving aspect ratios across the plots. | ||||||||
| #' | ||||||||
| #' @seealso [print.ggplot()] and [benchplot()] for | ||||||||
| #' for functions that contain the complete set of steps for generating | ||||||||
| #' a ggplot2 plot. | ||||||||
| #' @return a [gtable()] object | ||||||||
| #' @keywords internal | ||||||||
| #' @param data plot data generated by [ggplot_build()] | ||||||||
| #' @export | ||||||||
| ggplot_gtable <- function(data) { | ||||||||
| UseMethod('ggplot_gtable') | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_gtable.ggplot_built <- function(data) { | ||||||||
| plot <- data$plot | ||||||||
| layout <- data$layout | ||||||||
| data <- data$data | ||||||||
| theme <- plot_theme(plot) | ||||||||
| geom_grobs <- Map(function(l, d) l$draw_geom(d, layout), plot$layers, data) | ||||||||
| plot_table <- layout$render(geom_grobs, data, theme, plot$labels) | ||||||||
| # Legends | ||||||||
| position <- theme$legend.position %||% "right" | ||||||||
| if (length(position) == 2) { | ||||||||
| position <- "manual" | ||||||||
| } | ||||||||
| legend_box <- if (position != "none") { | ||||||||
| build_guides(plot$scales, plot$layers, plot$mapping, position, theme, plot$guides, plot$labels) | ||||||||
| } else { | ||||||||
| zeroGrob() | ||||||||
| } | ||||||||
| if (is.zero(legend_box)) { | ||||||||
| position <- "none" | ||||||||
| } else { | ||||||||
| # these are a bad hack, since it modifies the contents of viewpoint directly... | ||||||||
| legend_width <- gtable_width(legend_box) | ||||||||
| legend_height <- gtable_height(legend_box) | ||||||||
| # Set the justification of the legend box | ||||||||
| # First value is xjust, second value is yjust | ||||||||
| just <- valid.just(theme$legend.justification) | ||||||||
| xjust <- just[1] | ||||||||
| yjust <- just[2] | ||||||||
| if (position == "manual") { | ||||||||
| xpos <- theme$legend.position[1] | ||||||||
| ypos <- theme$legend.position[2] | ||||||||
| # x and y are specified via theme$legend.position (i.e., coords) | ||||||||
| legend_box <- editGrob(legend_box, | ||||||||
| vp = viewport(x = xpos, y = ypos, just = c(xjust, yjust), | ||||||||
| height = legend_height, width = legend_width)) | ||||||||
| } else { | ||||||||
| # x and y are adjusted using justification of legend box (i.e., theme$legend.justification) | ||||||||
| legend_box <- editGrob(legend_box, | ||||||||
| vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust))) | ||||||||
| legend_box <- gtable_add_rows(legend_box, unit(yjust, 'null')) | ||||||||
| legend_box <- gtable_add_rows(legend_box, unit(1 - yjust, 'null'), 0) | ||||||||
| legend_box <- gtable_add_cols(legend_box, unit(xjust, 'null'), 0) | ||||||||
| legend_box <- gtable_add_cols(legend_box, unit(1 - xjust, 'null')) | ||||||||
| } | ||||||||
| } | ||||||||
| panel_dim <- find_panel(plot_table) | ||||||||
| # for align-to-device, use this: | ||||||||
| # panel_dim <- summarise(plot_table$layout, t = min(t), r = max(r), b = max(b), l = min(l)) | ||||||||
| theme$legend.box.spacing <- theme$legend.box.spacing %||% unit(0.2, 'cm') | ||||||||
| if (position == "left") { | ||||||||
| plot_table <- gtable_add_cols(plot_table, theme$legend.box.spacing, pos = 0) | ||||||||
| plot_table <- gtable_add_cols(plot_table, legend_width, pos = 0) | ||||||||
| plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off", | ||||||||
| t = panel_dim$t, b = panel_dim$b, l = 1, r = 1, name = "guide-box") | ||||||||
| } else if (position == "right") { | ||||||||
| plot_table <- gtable_add_cols(plot_table, theme$legend.box.spacing, pos = -1) | ||||||||
| plot_table <- gtable_add_cols(plot_table, legend_width, pos = -1) | ||||||||
| plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off", | ||||||||
| t = panel_dim$t, b = panel_dim$b, l = -1, r = -1, name = "guide-box") | ||||||||
| } else if (position == "bottom") { | ||||||||
| plot_table <- gtable_add_rows(plot_table, theme$legend.box.spacing, pos = -1) | ||||||||
| plot_table <- gtable_add_rows(plot_table, legend_height, pos = -1) | ||||||||
| plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off", | ||||||||
| t = -1, b = -1, l = panel_dim$l, r = panel_dim$r, name = "guide-box") | ||||||||
| } else if (position == "top") { | ||||||||
| plot_table <- gtable_add_rows(plot_table, theme$legend.box.spacing, pos = 0) | ||||||||
| plot_table <- gtable_add_rows(plot_table, legend_height, pos = 0) | ||||||||
| plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off", | ||||||||
| t = 1, b = 1, l = panel_dim$l, r = panel_dim$r, name = "guide-box") | ||||||||
| } else if (position == "manual") { | ||||||||
| # should guide box expand whole region or region without margin? | ||||||||
| plot_table <- gtable_add_grob(plot_table, legend_box, | ||||||||
| t = panel_dim$t, b = panel_dim$b, l = panel_dim$l, r = panel_dim$r, | ||||||||
| clip = "off", name = "guide-box") | ||||||||
| } | ||||||||
| # Title | ||||||||
| title <- element_render(theme, "plot.title", plot$labels$title, margin_y = TRUE) | ||||||||
| title_height <- grobHeight(title) | ||||||||
| # Subtitle | ||||||||
| subtitle <- element_render(theme, "plot.subtitle", plot$labels$subtitle, margin_y = TRUE) | ||||||||
| subtitle_height <- grobHeight(subtitle) | ||||||||
| # Tag | ||||||||
| tag <- element_render(theme, "plot.tag", plot$labels$tag, margin_y = TRUE, margin_x = TRUE) | ||||||||
| tag_height <- grobHeight(tag) | ||||||||
| tag_width <- grobWidth(tag) | ||||||||
| # whole plot annotation | ||||||||
| caption <- element_render(theme, "plot.caption", plot$labels$caption, margin_y = TRUE) | ||||||||
| caption_height <- grobHeight(caption) | ||||||||
| pans <- plot_table$layout[grepl("^panel", plot_table$layout$name), , | ||||||||
| drop = FALSE] | ||||||||
| plot_table <- gtable_add_rows(plot_table, subtitle_height, pos = 0) | ||||||||
| plot_table <- gtable_add_grob(plot_table, subtitle, name = "subtitle", | ||||||||
| t = 1, b = 1, l = min(pans$l), r = max(pans$r), clip = "off") | ||||||||
| plot_table <- gtable_add_rows(plot_table, title_height, pos = 0) | ||||||||
| plot_table <- gtable_add_grob(plot_table, title, name = "title", | ||||||||
| t = 1, b = 1, l = min(pans$l), r = max(pans$r), clip = "off") | ||||||||
| plot_table <- gtable_add_rows(plot_table, caption_height, pos = -1) | ||||||||
| plot_table <- gtable_add_grob(plot_table, caption, name = "caption", | ||||||||
| t = -1, b = -1, l = min(pans$l), r = max(pans$r), clip = "off") | ||||||||
| plot_table <- gtable_add_rows(plot_table, unit(0, 'pt'), pos = 0) | ||||||||
| plot_table <- gtable_add_cols(plot_table, unit(0, 'pt'), pos = 0) | ||||||||
| plot_table <- gtable_add_rows(plot_table, unit(0, 'pt'), pos = -1) | ||||||||
| plot_table <- gtable_add_cols(plot_table, unit(0, 'pt'), pos = -1) | ||||||||
| tag_pos <- theme$plot.tag.position %||% "topleft" | ||||||||
| if (length(tag_pos) == 2) tag_pos <- "manual" | ||||||||
| valid_pos <- c("topleft", "top", "topright", "left", "right", "bottomleft", | ||||||||
| "bottom", "bottomright") | ||||||||
| if (!(tag_pos == "manual" || tag_pos %in% valid_pos)) { | ||||||||
| stop("plot.tag.position should be a coordinate or one of ", | ||||||||
| paste(valid_pos, collapse = ', '), call. = FALSE) | ||||||||
| } | ||||||||
| if (tag_pos == "manual") { | ||||||||
| xpos <- theme$plot.tag.position[1] | ||||||||
| ypos <- theme$plot.tag.position[2] | ||||||||
| tag_parent <- justify_grobs(tag, x = xpos, y = ypos, | ||||||||
| hjust = theme$plot.tag$hjust, | ||||||||
| vjust = theme$plot.tag$vjust, | ||||||||
| int_angle = theme$plot.tag$angle, | ||||||||
| debug = theme$plot.tag$debug) | ||||||||
| plot_table <- gtable_add_grob(plot_table, tag_parent, name = "tag", t = 1, | ||||||||
| b = nrow(plot_table), l = 1, | ||||||||
| r = ncol(plot_table), clip = "off") | ||||||||
| } else { | ||||||||
| # Widths and heights are reassembled below instead of assigning into them | ||||||||
| # in order to avoid bug in grid 3.2 and below. | ||||||||
| if (tag_pos == "topleft") { | ||||||||
| plot_table$widths <- unit.c(tag_width, plot_table$widths[-1]) | ||||||||
| plot_table$heights <- unit.c(tag_height, plot_table$heights[-1]) | ||||||||
| plot_table <- gtable_add_grob(plot_table, tag, name = "tag", | ||||||||
| t = 1, l = 1, clip = "off") | ||||||||
| } else if (tag_pos == "top") { | ||||||||
| plot_table$heights <- unit.c(tag_height, plot_table$heights[-1]) | ||||||||
| plot_table <- gtable_add_grob(plot_table, tag, name = "tag", | ||||||||
| t = 1, l = 1, r = ncol(plot_table), | ||||||||
| clip = "off") | ||||||||
| } else if (tag_pos == "topright") { | ||||||||
| plot_table$widths <- unit.c(plot_table$widths[-ncol(plot_table)], tag_width) | ||||||||
| plot_table$heights <- unit.c(tag_height, plot_table$heights[-1]) | ||||||||
| plot_table <- gtable_add_grob(plot_table, tag, name = "tag", | ||||||||
| t = 1, l = ncol(plot_table), clip = "off") | ||||||||
| } else if (tag_pos == "left") { | ||||||||
| plot_table$widths <- unit.c(tag_width, plot_table$widths[-1]) | ||||||||
| plot_table <- gtable_add_grob(plot_table, tag, name = "tag", | ||||||||
| t = 1, b = nrow(plot_table), l = 1, | ||||||||
| clip = "off") | ||||||||
| } else if (tag_pos == "right") { | ||||||||
| plot_table$widths <- unit.c(plot_table$widths[-ncol(plot_table)], tag_width) | ||||||||
| plot_table <- gtable_add_grob(plot_table, tag, name = "tag", | ||||||||
| t = 1, b = nrow(plot_table), l = ncol(plot_table), | ||||||||
| clip = "off") | ||||||||
| } else if (tag_pos == "bottomleft") { | ||||||||
| plot_table$widths <- unit.c(tag_width, plot_table$widths[-1]) | ||||||||
| plot_table$heights <- unit.c(plot_table$heights[-nrow(plot_table)], tag_height) | ||||||||
| plot_table <- gtable_add_grob(plot_table, tag, name = "tag", | ||||||||
| t = nrow(plot_table), l = 1, clip = "off") | ||||||||
| } else if (tag_pos == "bottom") { | ||||||||
| plot_table$heights <- unit.c(plot_table$heights[-nrow(plot_table)], tag_height) | ||||||||
| plot_table <- gtable_add_grob(plot_table, tag, name = "tag", | ||||||||
| t = nrow(plot_table), l = 1, r = ncol(plot_table), clip = "off") | ||||||||
| } else if (tag_pos == "bottomright") { | ||||||||
| plot_table$widths <- unit.c(plot_table$widths[-ncol(plot_table)], tag_width) | ||||||||
| plot_table$heights <- unit.c(plot_table$heights[-nrow(plot_table)], tag_height) | ||||||||
| plot_table <- gtable_add_grob(plot_table, tag, name = "tag", | ||||||||
| t = nrow(plot_table), l = ncol(plot_table), clip = "off") | ||||||||
| } | ||||||||
| } | ||||||||
| # Margins | ||||||||
| plot_table <- gtable_add_rows(plot_table, theme$plot.margin[1], pos = 0) | ||||||||
| plot_table <- gtable_add_cols(plot_table, theme$plot.margin[2]) | ||||||||
| plot_table <- gtable_add_rows(plot_table, theme$plot.margin[3]) | ||||||||
| plot_table <- gtable_add_cols(plot_table, theme$plot.margin[4], pos = 0) | ||||||||
| if (inherits(theme$plot.background, "element")) { | ||||||||
| plot_table <- gtable_add_grob(plot_table, | ||||||||
| element_render(theme, "plot.background"), | ||||||||
| t = 1, l = 1, b = -1, r = -1, name = "background", z = -Inf) | ||||||||
| plot_table$layout <- plot_table$layout[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1)),] | ||||||||
| plot_table$grobs <- plot_table$grobs[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1))] | ||||||||
| } | ||||||||
| plot_table | ||||||||
| } | ||||||||
| #' Generate a ggplot2 plot grob. | ||||||||
| #' | ||||||||
| #' @param x ggplot2 object | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| ggplotGrob <- function(x) { | ||||||||
| ggplot_gtable(ggplot_build(x)) | ||||||||
| } | ||||||||
| ggplot2/R/theme-elements.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Theme elements | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' In conjunction with the \link{theme} system, the `element_` functions | ||||||||
| #' specify the display of how non-data components of the plot are a drawn. | ||||||||
| #' | ||||||||
| #' - `element_blank`: draws nothing, and assigns no space. | ||||||||
| #' - `element_rect`: borders and backgrounds. | ||||||||
| #' - `element_line`: lines. | ||||||||
| #' - `element_text`: text. | ||||||||
| #' | ||||||||
| #' `rel()` is used to specify sizes relative to the parent, | ||||||||
| #' `margins()` is used to specify the margins of elements. | ||||||||
| #' | ||||||||
| #' @param fill Fill colour. | ||||||||
| #' @param colour,color Line/border colour. Color is an alias for colour. | ||||||||
| #' @param size Line/border size in mm; text size in pts. | ||||||||
| #' @param inherit.blank Should this element inherit the existence of an | ||||||||
| #' `element_blank` among its parents? If `TRUE` the existence of | ||||||||
| #' a blank element among its parents will cause this element to be blank as | ||||||||
| #' well. If `FALSE` any blank parent element will be ignored when | ||||||||
| #' calculating final element state. | ||||||||
| #' @return An S3 object of class `element`, `rel`, or `margin`. | ||||||||
| #' @examples | ||||||||
| #' plot <- ggplot(mpg, aes(displ, hwy)) + geom_point() | ||||||||
| #' | ||||||||
| #' plot + theme( | ||||||||
| #' panel.background = element_blank(), | ||||||||
| #' axis.text = element_blank() | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' plot + theme( | ||||||||
| #' axis.text = element_text(colour = "red", size = rel(1.5)) | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' plot + theme( | ||||||||
| #' axis.line = element_line(arrow = arrow()) | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' plot + theme( | ||||||||
| #' panel.background = element_rect(fill = "white"), | ||||||||
| #' plot.margin = margin(2, 2, 2, 2, "cm"), | ||||||||
| #' plot.background = element_rect( | ||||||||
| #' fill = "grey90", | ||||||||
| #' colour = "black", | ||||||||
| #' size = 1 | ||||||||
| #' ) | ||||||||
| #' ) | ||||||||
| #' @name element | ||||||||
| #' @aliases NULL | ||||||||
| NULL | ||||||||
| #' @export | ||||||||
| #' @rdname element | ||||||||
| element_blank <- function() { | ||||||||
| structure( | ||||||||
| list(), | ||||||||
| class = c("element_blank", "element") | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname element | ||||||||
| element_rect <- function(fill = NULL, colour = NULL, size = NULL, | ||||||||
| linetype = NULL, color = NULL, inherit.blank = FALSE) { | ||||||||
| if (!is.null(color)) colour <- color | ||||||||
| structure( | ||||||||
| list(fill = fill, colour = colour, size = size, linetype = linetype, | ||||||||
| inherit.blank = inherit.blank), | ||||||||
| class = c("element_rect", "element") | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname element | ||||||||
| #' @param linetype Line type. An integer (0:8), a name (blank, solid, | ||||||||
| #' dashed, dotted, dotdash, longdash, twodash), or a string with | ||||||||
| #' an even number (up to eight) of hexadecimal digits which give the | ||||||||
| #' lengths in consecutive positions in the string. | ||||||||
| #' @param lineend Line end Line end style (round, butt, square) | ||||||||
| #' @param arrow Arrow specification, as created by [grid::arrow()] | ||||||||
| element_line <- function(colour = NULL, size = NULL, linetype = NULL, | ||||||||
| lineend = NULL, color = NULL, arrow = NULL, inherit.blank = FALSE) { | ||||||||
| if (!is.null(color)) colour <- color | ||||||||
| if (is.null(arrow)) arrow <- FALSE | ||||||||
| structure( | ||||||||
| list(colour = colour, size = size, linetype = linetype, lineend = lineend, | ||||||||
| arrow = arrow, inherit.blank = inherit.blank), | ||||||||
| class = c("element_line", "element") | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @param family Font family | ||||||||
| #' @param face Font face ("plain", "italic", "bold", "bold.italic") | ||||||||
| #' @param hjust Horizontal justification (in \eqn{[0, 1]}) | ||||||||
| #' @param vjust Vertical justification (in \eqn{[0, 1]}) | ||||||||
| #' @param angle Angle (in \eqn{[0, 360]}) | ||||||||
| #' @param lineheight Line height | ||||||||
| #' @param margin Margins around the text. See [margin()] for more | ||||||||
| #' details. When creating a theme, the margins should be placed on the | ||||||||
| #' side of the text facing towards the center of the plot. | ||||||||
| #' @param debug If `TRUE`, aids visual debugging by drawing a solid | ||||||||
| #' rectangle behind the complete text area, and a point where each label | ||||||||
| #' is anchored. | ||||||||
| #' @export | ||||||||
| #' @rdname element | ||||||||
| element_text <- function(family = NULL, face = NULL, colour = NULL, | ||||||||
| size = NULL, hjust = NULL, vjust = NULL, angle = NULL, lineheight = NULL, | ||||||||
| color = NULL, margin = NULL, debug = NULL, inherit.blank = FALSE) { | ||||||||
| if (!is.null(color)) colour <- color | ||||||||
| structure( | ||||||||
| list(family = family, face = face, colour = colour, size = size, | ||||||||
| hjust = hjust, vjust = vjust, angle = angle, lineheight = lineheight, | ||||||||
| margin = margin, debug = debug, inherit.blank = inherit.blank), | ||||||||
| class = c("element_text", "element") | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| print.element <- function(x, ...) utils::str(x) | ||||||||
| #' @param x A single number specifying size relative to parent element. | ||||||||
| #' @rdname element | ||||||||
| #' @export | ||||||||
| rel <- function(x) { | ||||||||
| structure(x, class = "rel") | ||||||||
| } | ||||||||
| #' @export | ||||||||
| print.rel <- function(x, ...) print(noquote(paste(x, " *", sep = ""))) | ||||||||
| #' Reports whether x is a rel object | ||||||||
| #' @param x An object to test | ||||||||
| #' @keywords internal | ||||||||
| is.rel <- function(x) inherits(x, "rel") | ||||||||
| # Given a theme object and element name, return a grob for the element | ||||||||
| element_render <- function(theme, element, ..., name = NULL) { | ||||||||
| # Get the element from the theme, calculating inheritance | ||||||||
| el <- calc_element(element, theme) | ||||||||
| if (is.null(el)) { | ||||||||
| message("Theme element ", element, " missing") | ||||||||
| return(zeroGrob()) | ||||||||
| } | ||||||||
| grob <- element_grob(el, ...) | ||||||||
| ggname(paste(element, name, sep = "."), grob) | ||||||||
| } | ||||||||
| # Returns NULL if x is length 0 | ||||||||
| len0_null <- function(x) { | ||||||||
| if (length(x) == 0) NULL | ||||||||
| else x | ||||||||
| } | ||||||||
| #' Generate grid grob from theme element | ||||||||
| #' | ||||||||
| #' @param element Theme element, i.e. `element_rect` or similar. | ||||||||
| #' @param ... Other arguments to control specific of rendering. This is | ||||||||
| #' usually at least position. See the source code for individual methods. | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| element_grob <- function(element, ...) { | ||||||||
| UseMethod("element_grob") | ||||||||
| } | ||||||||
| #' @export | ||||||||
| element_grob.element_blank <- function(element, ...) zeroGrob() | ||||||||
| #' @export | ||||||||
| element_grob.element_rect <- function(element, x = 0.5, y = 0.5, | ||||||||
| width = 1, height = 1, | ||||||||
| fill = NULL, colour = NULL, size = NULL, linetype = NULL, ...) { | ||||||||
| # The gp settings can override element_gp | ||||||||
| gp <- gpar(lwd = len0_null(size * .pt), col = colour, fill = fill, lty = linetype) | ||||||||
| element_gp <- gpar(lwd = len0_null(element$size * .pt), col = element$colour, | ||||||||
| fill = element$fill, lty = element$linetype) | ||||||||
| rectGrob(x, y, width, height, gp = modify_list(element_gp, gp), ...) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| element_grob.element_text <- function(element, label = "", x = NULL, y = NULL, | ||||||||
| family = NULL, face = NULL, colour = NULL, size = NULL, | ||||||||
| hjust = NULL, vjust = NULL, angle = NULL, lineheight = NULL, | ||||||||
| margin = NULL, margin_x = FALSE, margin_y = FALSE, ...) { | ||||||||
| if (is.null(label)) | ||||||||
| return(zeroGrob()) | ||||||||
| vj <- vjust %||% element$vjust | ||||||||
| hj <- hjust %||% element$hjust | ||||||||
| margin <- margin %||% element$margin | ||||||||
| angle <- angle %||% element$angle %||% 0 | ||||||||
| # The gp settings can override element_gp | ||||||||
| gp <- gpar(fontsize = size, col = colour, | ||||||||
| fontfamily = family, fontface = face, | ||||||||
| lineheight = lineheight) | ||||||||
| element_gp <- gpar(fontsize = element$size, col = element$colour, | ||||||||
| fontfamily = element$family, fontface = element$face, | ||||||||
| lineheight = element$lineheight) | ||||||||
| titleGrob(label, x, y, hjust = hj, vjust = vj, angle = angle, | ||||||||
| gp = modify_list(element_gp, gp), margin = margin, | ||||||||
| margin_x = margin_x, margin_y = margin_y, debug = element$debug) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| element_grob.element_line <- function(element, x = 0:1, y = 0:1, | ||||||||
| colour = NULL, size = NULL, linetype = NULL, lineend = NULL, | ||||||||
| default.units = "npc", id.lengths = NULL, ...) { | ||||||||
| # The gp settings can override element_gp | ||||||||
| gp <- gpar(lwd = len0_null(size * .pt), col = colour, lty = linetype, lineend = lineend) | ||||||||
| element_gp <- gpar(lwd = len0_null(element$size * .pt), col = element$colour, | ||||||||
| lty = element$linetype, lineend = element$lineend) | ||||||||
| arrow <- if (is.logical(element$arrow) && !element$arrow) { | ||||||||
| NULL | ||||||||
| } else { | ||||||||
| element$arrow | ||||||||
| } | ||||||||
| polylineGrob( | ||||||||
| x, y, default.units = default.units, | ||||||||
| gp = modify_list(element_gp, gp), | ||||||||
| id.lengths = id.lengths, arrow = arrow, ... | ||||||||
| ) | ||||||||
| } | ||||||||
| # Define an element's class and what other elements it inherits from | ||||||||
| # | ||||||||
| # @param class The name of class (like "element_line", "element_text", | ||||||||
| # or the reserved "character", which means a character vector (not | ||||||||
| # "character" class) | ||||||||
| # @param inherit A vector of strings, naming the elements that this | ||||||||
| # element inherits from. | ||||||||
| el_def <- function(class = NULL, inherit = NULL, description = NULL) { | ||||||||
| list(class = class, inherit = inherit, description = description) | ||||||||
| } | ||||||||
| # This data structure represents the theme elements and the inheritance | ||||||||
| # among them. (In the future, .element_tree should be removed in favor | ||||||||
| # of direct assignment to ggplot_global$element_tree, see below.) | ||||||||
| .element_tree <- list( | ||||||||
| line = el_def("element_line"), | ||||||||
| rect = el_def("element_rect"), | ||||||||
| text = el_def("element_text"), | ||||||||
| title = el_def("element_text", "text"), | ||||||||
| axis.line = el_def("element_line", "line"), | ||||||||
| axis.text = el_def("element_text", "text"), | ||||||||
| axis.title = el_def("element_text", "title"), | ||||||||
| axis.ticks = el_def("element_line", "line"), | ||||||||
| legend.key.size = el_def("unit"), | ||||||||
| panel.grid = el_def("element_line", "line"), | ||||||||
| panel.grid.major = el_def("element_line", "panel.grid"), | ||||||||
| panel.grid.minor = el_def("element_line", "panel.grid"), | ||||||||
| strip.text = el_def("element_text", "text"), | ||||||||
| axis.line.x = el_def("element_line", "axis.line"), | ||||||||
| axis.line.x.top = el_def("element_line", "axis.line.x"), | ||||||||
| axis.line.x.bottom = el_def("element_line", "axis.line.x"), | ||||||||
| axis.line.y = el_def("element_line", "axis.line"), | ||||||||
| axis.line.y.left = el_def("element_line", "axis.line.y"), | ||||||||
| axis.line.y.right = el_def("element_line", "axis.line.y"), | ||||||||
| axis.text.x = el_def("element_text", "axis.text"), | ||||||||
| axis.text.x.top = el_def("element_text", "axis.text.x"), | ||||||||
| axis.text.x.bottom = el_def("element_text", "axis.text.x"), | ||||||||
| axis.text.y = el_def("element_text", "axis.text"), | ||||||||
| axis.text.y.left = el_def("element_text", "axis.text.y"), | ||||||||
| axis.text.y.right = el_def("element_text", "axis.text.y"), | ||||||||
| axis.ticks.length = el_def("unit"), | ||||||||
| axis.ticks.x = el_def("element_line", "axis.ticks"), | ||||||||
| axis.ticks.x.top = el_def("element_line", "axis.ticks.x"), | ||||||||
| axis.ticks.x.bottom = el_def("element_line", "axis.ticks.x"), | ||||||||
| axis.ticks.y = el_def("element_line", "axis.ticks"), | ||||||||
| axis.ticks.y.left = el_def("element_line", "axis.ticks.y"), | ||||||||
| axis.ticks.y.right = el_def("element_line", "axis.ticks.y"), | ||||||||
| axis.title.x = el_def("element_text", "axis.title"), | ||||||||
| axis.title.x.top = el_def("element_text", "axis.title.x"), | ||||||||
| axis.title.x.bottom = el_def("element_text", "axis.title.x"), | ||||||||
| axis.title.y = el_def("element_text", "axis.title"), | ||||||||
| axis.title.y.left = el_def("element_text", "axis.title.y"), | ||||||||
| axis.title.y.right = el_def("element_text", "axis.title.y"), | ||||||||
| legend.background = el_def("element_rect", "rect"), | ||||||||
| legend.margin = el_def("margin"), | ||||||||
| legend.spacing = el_def("unit"), | ||||||||
| legend.spacing.x = el_def("unit", "legend.spacing"), | ||||||||
| legend.spacing.y = el_def("unit", "legend.spacing"), | ||||||||
| legend.key = el_def("element_rect", "rect"), | ||||||||
| legend.key.height = el_def("unit", "legend.key.size"), | ||||||||
| legend.key.width = el_def("unit", "legend.key.size"), | ||||||||
| legend.text = el_def("element_text", "text"), | ||||||||
| legend.text.align = el_def("character"), | ||||||||
| legend.title = el_def("element_text", "title"), | ||||||||
| legend.title.align = el_def("character"), | ||||||||
| legend.position = el_def("character"), # Need to also accept numbers | ||||||||
| legend.direction = el_def("character"), | ||||||||
| legend.justification = el_def("character"), | ||||||||
| legend.box = el_def("character"), | ||||||||
| legend.box.just = el_def("character"), | ||||||||
| legend.box.margin = el_def("margin"), | ||||||||
| legend.box.background = el_def("element_rect", "rect"), | ||||||||
| legend.box.spacing = el_def("unit"), | ||||||||
| panel.background = el_def("element_rect", "rect"), | ||||||||
| panel.border = el_def("element_rect", "rect"), | ||||||||
| panel.spacing = el_def("unit"), | ||||||||
| panel.spacing.x = el_def("unit", "panel.spacing"), | ||||||||
| panel.spacing.y = el_def("unit", "panel.spacing"), | ||||||||
| panel.grid.major.x = el_def("element_line", "panel.grid.major"), | ||||||||
| panel.grid.major.y = el_def("element_line", "panel.grid.major"), | ||||||||
| panel.grid.minor.x = el_def("element_line", "panel.grid.minor"), | ||||||||
| panel.grid.minor.y = el_def("element_line", "panel.grid.minor"), | ||||||||
| panel.ontop = el_def("logical"), | ||||||||
| strip.background = el_def("element_rect", "rect"), | ||||||||
| strip.background.x = el_def("element_rect", "strip.background"), | ||||||||
| strip.background.y = el_def("element_rect", "strip.background"), | ||||||||
| strip.text.x = el_def("element_text", "strip.text"), | ||||||||
| strip.text.y = el_def("element_text", "strip.text"), | ||||||||
| strip.placement = el_def("character"), | ||||||||
| strip.placement.x = el_def("character", "strip.placement"), | ||||||||
| strip.placement.y = el_def("character", "strip.placement"), | ||||||||
| strip.switch.pad.grid = el_def("unit"), | ||||||||
| strip.switch.pad.wrap = el_def("unit"), | ||||||||
| plot.background = el_def("element_rect", "rect"), | ||||||||
| plot.title = el_def("element_text", "title"), | ||||||||
| plot.subtitle = el_def("element_text", "title"), | ||||||||
| plot.caption = el_def("element_text", "title"), | ||||||||
| plot.tag = el_def("element_text", "title"), | ||||||||
| plot.tag.position = el_def("character"), # Need to also accept numbers | ||||||||
| plot.margin = el_def("margin"), | ||||||||
| aspect.ratio = el_def("character") | ||||||||
| ) | ||||||||
| ggplot_global$element_tree <- .element_tree | ||||||||
| # Check that an element object has the proper class | ||||||||
| # | ||||||||
| # Given an element object and the name of the element, this function | ||||||||
| # checks it against the element inheritance tree to make sure the | ||||||||
| # element is of the correct class | ||||||||
| # | ||||||||
| # It throws error if invalid, and returns invisible() if valid. | ||||||||
| # | ||||||||
| # @param el an element | ||||||||
| # @param elname the name of the element | ||||||||
| validate_element <- function(el, elname) { | ||||||||
| eldef <- ggplot_global$element_tree[[elname]] | ||||||||
| if (is.null(eldef)) { | ||||||||
| stop('"', elname, '" is not a valid theme element name.') | ||||||||
| } | ||||||||
| # NULL values for elements are OK | ||||||||
| if (is.null(el)) return() | ||||||||
| if (eldef$class == "character") { | ||||||||
| # Need to be a bit looser here since sometimes it's a string like "top" | ||||||||
| # but sometimes its a vector like c(0,0) | ||||||||
| if (!is.character(el) && !is.numeric(el)) | ||||||||
| stop("Element ", elname, " must be a string or numeric vector.") | ||||||||
| } else if (eldef$class == "margin") { | ||||||||
| if (!is.unit(el) && length(el) == 4) | ||||||||
| stop("Element ", elname, " must be a unit vector of length 4.") | ||||||||
| } else if (!inherits(el, eldef$class) && !inherits(el, "element_blank")) { | ||||||||
| stop("Element ", elname, " must be a ", eldef$class, " object.") | ||||||||
| } | ||||||||
| invisible() | ||||||||
| } | ||||||||
| ggplot2/R/guides-grid.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| # Produce a grob to be used as for panel backgrounds | ||||||||
| guide_grid <- function(theme, x.minor, x.major, y.minor, y.major) { | ||||||||
| x.minor <- setdiff(x.minor, x.major) | ||||||||
| y.minor <- setdiff(y.minor, y.major) | ||||||||
| ggname("grill", grobTree( | ||||||||
| element_render(theme, "panel.background"), | ||||||||
| if (length(y.minor) > 0) element_render( | ||||||||
| theme, "panel.grid.minor.y", | ||||||||
| x = rep(0:1, length(y.minor)), y = rep(y.minor, each = 2), | ||||||||
| id.lengths = rep(2, length(y.minor)) | ||||||||
| ), | ||||||||
| if (length(x.minor) > 0) element_render( | ||||||||
| theme, "panel.grid.minor.x", | ||||||||
| x = rep(x.minor, each = 2), y = rep(0:1, length(x.minor)), | ||||||||
| id.lengths = rep(2, length(x.minor)) | ||||||||
| ), | ||||||||
| if (length(y.major) > 0) element_render( | ||||||||
| theme, "panel.grid.major.y", | ||||||||
| x = rep(0:1, length(y.major)), y = rep(y.major, each = 2), | ||||||||
| id.lengths = rep(2, length(y.major)) | ||||||||
| ), | ||||||||
| if (length(x.major) > 0) element_render( | ||||||||
| theme, "panel.grid.major.x", | ||||||||
| x = rep(x.major, each = 2), y = rep(0:1, length(x.major)), | ||||||||
| id.lengths = rep(2, length(x.major)) | ||||||||
| ) | ||||||||
| )) | ||||||||
| } | ||||||||
| ggplot2/R/coord-.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' @section Coordinate systems: | ||||||||
| #' | ||||||||
| #' All `coord_*` functions (like `coord_trans`) return a `Coord*` | ||||||||
| #' object (like `CoordTrans`). | ||||||||
| #' | ||||||||
| #' Each of the `Coord*` objects is a [ggproto()] object, | ||||||||
| #' descended from the top-level `Coord`. To create a new type of Coord | ||||||||
| #' object, you typically will want to implement one or more of the following: | ||||||||
| #' | ||||||||
| #' - `aspect`: Returns the desired aspect ratio for the plot. | ||||||||
| #' - `labels`: Returns a list containing labels for x and y. | ||||||||
| #' - `render_fg`: Renders foreground elements. | ||||||||
| #' - `render_bg`: Renders background elements. | ||||||||
| #' - `render_axis_h`: Renders the horizontal axes. | ||||||||
| #' - `render_axis_v`: Renders the vertical axes. | ||||||||
| #' - `backtransform_range(panel_params)`: Extracts the panel range provided | ||||||||
| #' in `panel_params` (created by `setup_panel_params()`, see below) and | ||||||||
| #' back-transforms to data coordinates. This back-transformation can be needed | ||||||||
| #' for coords such as `coord_trans()` where the range in the transformed | ||||||||
| #' coordinates differs from the range in the untransformed coordinates. Returns | ||||||||
| #' a list of two ranges, `x` and `y`, and these correspond to the variables | ||||||||
| #' mapped to the `x` and `y` aesthetics, even for coords such as `coord_flip()` | ||||||||
| #' where the `x` aesthetic is shown along the y direction and vice versa. | ||||||||
| #' - `range(panel_params)`: Extracts the panel range provided | ||||||||
| #' in `panel_params` (created by `setup_panel_params()`, see below) and | ||||||||
| #' returns it. Unlike `backtransform_range()`, this function does not perform | ||||||||
| #' any back-transformation and instead returns final transformed coordinates. Returns | ||||||||
| #' a list of two ranges, `x` and `y`, and these correspond to the variables | ||||||||
| #' mapped to the `x` and `y` aesthetics, even for coords such as `coord_flip()` | ||||||||
| #' where the `x` aesthetic is shown along the y direction and vice versa. | ||||||||
| #' - `transform`: Transforms x and y coordinates. | ||||||||
| #' - `distance`: Calculates distance. | ||||||||
| #' - `is_linear`: Returns `TRUE` if the coordinate system is | ||||||||
| #' linear; `FALSE` otherwise. | ||||||||
| #' - `is_free`: Returns `TRUE` if the coordinate system supports free | ||||||||
| #' positional scales; `FALSE` otherwise. | ||||||||
| #' - `setup_panel_params(scale_x, scale_y, params)`: Determines the appropriate | ||||||||
| #' x and y ranges for each panel, and also calculates anything else needed to | ||||||||
| #' render the panel and axes, such as tick positions and labels for major | ||||||||
| #' and minor ticks. Returns all this information in a named list. | ||||||||
| #' - `setup_data(data, params)`: Allows the coordinate system to | ||||||||
| #' manipulate the plot data. Should return list of data frames. | ||||||||
| #' - `setup_layout(layout, params)`: Allows the coordinate | ||||||||
| #' system to manipulate the `layout` data frame which assigns | ||||||||
| #' data to panels and scales. | ||||||||
| #' | ||||||||
| #' @rdname ggplot2-ggproto | ||||||||
| #' @format NULL | ||||||||
| #' @usage NULL | ||||||||
| #' @export | ||||||||
| Coord <- ggproto("Coord", | ||||||||
| # Is this the default coordinate system? | ||||||||
| default = FALSE, | ||||||||
| # should drawing be clipped to the extent of the plot panel? | ||||||||
| # "on" = yes, "off" = no | ||||||||
| clip = "on", | ||||||||
| aspect = function(ranges) NULL, | ||||||||
| labels = function(panel_params) panel_params, | ||||||||
| render_fg = function(panel_params, theme) element_render(theme, "panel.border"), | ||||||||
| render_bg = function(panel_params, theme) { | ||||||||
| x.major <- if (length(panel_params$x.major) > 0) unit(panel_params$x.major, "native") | ||||||||
| x.minor <- if (length(panel_params$x.minor) > 0) unit(panel_params$x.minor, "native") | ||||||||
| y.major <- if (length(panel_params$y.major) > 0) unit(panel_params$y.major, "native") | ||||||||
| y.minor <- if (length(panel_params$y.minor) > 0) unit(panel_params$y.minor, "native") | ||||||||
| guide_grid(theme, x.minor, x.major, y.minor, y.major) | ||||||||
| }, | ||||||||
| render_axis_h = function(panel_params, theme) { | ||||||||
| arrange <- panel_params$x.arrange %||% c("secondary", "primary") | ||||||||
| list( | ||||||||
| top = render_axis(panel_params, arrange[1], "x", "top", theme), | ||||||||
| bottom = render_axis(panel_params, arrange[2], "x", "bottom", theme) | ||||||||
| ) | ||||||||
| }, | ||||||||
| render_axis_v = function(panel_params, theme) { | ||||||||
| arrange <- panel_params$y.arrange %||% c("primary", "secondary") | ||||||||
| list( | ||||||||
| left = render_axis(panel_params, arrange[1], "y", "left", theme), | ||||||||
| right = render_axis(panel_params, arrange[2], "y", "right", theme) | ||||||||
| ) | ||||||||
| }, | ||||||||
| # transform range given in transformed coordinates | ||||||||
| # back into range in given in (possibly scale-transformed) | ||||||||
| # data coordinates | ||||||||
| backtransform_range = function(self, panel_params) { | ||||||||
| warning( | ||||||||
| "range backtransformation not implemented in this coord; results may be wrong.", | ||||||||
| call. = FALSE | ||||||||
| ) | ||||||||
| # return result from range function for backwards compatibility | ||||||||
| # before ggplot2 3.0.1 | ||||||||
| self$range(panel_params) | ||||||||
| }, | ||||||||
| # return range stored in panel_params | ||||||||
| range = function(panel_params) { | ||||||||
| warning( | ||||||||
| "range calculation not implemented in this coord; results may be wrong.", | ||||||||
| call. = FALSE | ||||||||
| ) | ||||||||
| list(x = panel_params$x.range, y = panel_params$y.range) | ||||||||
| }, | ||||||||
| setup_panel_params = function(scale_x, scale_y, params = list()) { | ||||||||
| list() | ||||||||
| }, | ||||||||
| transform = function(data, range) NULL, | ||||||||
| distance = function(x, y, panel_params) NULL, | ||||||||
| is_linear = function() FALSE, | ||||||||
| # Does the coordinate system support free scaling of axes in a faceted plot? | ||||||||
| # Will generally have to return FALSE for coordinate systems that enforce a fixed aspect ratio. | ||||||||
| is_free = function() FALSE, | ||||||||
| setup_params = function(data) { | ||||||||
| list() | ||||||||
| }, | ||||||||
| setup_data = function(data, params = list()) { | ||||||||
| data | ||||||||
| }, | ||||||||
| setup_layout = function(layout, params) { | ||||||||
| layout | ||||||||
| }, | ||||||||
| # Optionally, modify list of x and y scales in place. Currently | ||||||||
| # used as a fudge for CoordFlip and CoordPolar | ||||||||
| modify_scales = function(scales_x, scales_y) { | ||||||||
| invisible() | ||||||||
| } | ||||||||
| ) | ||||||||
| #' Is this object a coordinate system? | ||||||||
| #' | ||||||||
| #' @export is.Coord | ||||||||
| #' @keywords internal | ||||||||
| is.Coord <- function(x) inherits(x, "Coord") | ||||||||
| expand_default <- function(scale, discrete = c(0, 0.6, 0, 0.6), continuous = c(0.05, 0, 0.05, 0)) { | ||||||||
| scale$expand %|W|% if (scale$is_discrete()) discrete else continuous | ||||||||
| } | ||||||||
| # Renders an axis with the correct orientation or zeroGrob if no axis should be | ||||||||
| # generated | ||||||||
| render_axis <- function(panel_params, axis, scale, position, theme) { | ||||||||
| if (axis == "primary") { | ||||||||
| guide_axis(panel_params[[paste0(scale, ".major")]], panel_params[[paste0(scale, ".labels")]], position, theme) | ||||||||
| } else if (axis == "secondary" && !is.null(panel_params[[paste0(scale, ".sec.major")]])) { | ||||||||
| guide_axis(panel_params[[paste0(scale, ".sec.major")]], panel_params[[paste0(scale, ".sec.labels")]], position, theme) | ||||||||
| } else { | ||||||||
| zeroGrob() | ||||||||
| } | ||||||||
| } | ||||||||
| ggplot2/R/layout.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| # The job of `Layout` is to coordinate: | ||||||||
| # * The coordinate system | ||||||||
| # * The faceting specification | ||||||||
| # * The individual position scales for each panel | ||||||||
| # | ||||||||
| # This includes managing the parameters for the facet and the coord | ||||||||
| # so that we don't modify the ggproto object in place. | ||||||||
| create_layout <- function(facet = FacetNull, coord = CoordCartesian) { | ||||||||
| ggproto(NULL, Layout, facet = facet, coord = coord) | ||||||||
| } | ||||||||
| #' @rdname ggplot2-ggproto | ||||||||
| #' @format NULL | ||||||||
| #' @usage NULL | ||||||||
| #' @export | ||||||||
| Layout <- ggproto("Layout", NULL, | ||||||||
| # The coordinate system and its parameters | ||||||||
| coord = NULL, | ||||||||
| coord_params = list(), | ||||||||
| # The faceting specification and its parameters | ||||||||
| facet = NULL, | ||||||||
| facet_params = list(), | ||||||||
| # A data frame giving the layout of the data into panels | ||||||||
| layout = NULL, | ||||||||
| # Per panel scales and params | ||||||||
| panel_scales_x = NULL, | ||||||||
| panel_scales_y = NULL, | ||||||||
| panel_params = NULL, | ||||||||
| setup = function(self, data, plot_data = new_data_frame(), plot_env = emptyenv()) { | ||||||||
| data <- c(list(plot_data), data) | ||||||||
| # Setup facets | ||||||||
| self$facet_params <- self$facet$setup_params(data, self$facet$params) | ||||||||
| self$facet_params$plot_env <- plot_env | ||||||||
| data <- self$facet$setup_data(data, self$facet_params) | ||||||||
| # Setup coords | ||||||||
| self$coord_params <- self$coord$setup_params(data) | ||||||||
| data <- self$coord$setup_data(data, self$coord_params) | ||||||||
| # Generate panel layout | ||||||||
| self$layout <- self$facet$compute_layout(data, self$facet_params) | ||||||||
| self$layout <- self$coord$setup_layout(self$layout, self$coord_params) | ||||||||
| check_layout(self$layout) | ||||||||
| # Add panel coordinates to the data for each layer | ||||||||
| lapply(data[-1], self$facet$map_data, | ||||||||
| layout = self$layout, | ||||||||
| params = self$facet_params | ||||||||
| ) | ||||||||
| }, | ||||||||
| # Assemble the facet fg & bg, the coord fg & bg, and the layers | ||||||||
| # Returns a gtable | ||||||||
| render = function(self, panels, data, theme, labels) { | ||||||||
| facet_bg <- self$facet$draw_back(data, | ||||||||
| self$layout, | ||||||||
| self$panel_scales_x, | ||||||||
| self$panel_scales_y, | ||||||||
| theme, | ||||||||
| self$facet_params | ||||||||
| ) | ||||||||
| facet_fg <- self$facet$draw_front( | ||||||||
| data, | ||||||||
| self$layout, | ||||||||
| self$panel_scales_x, | ||||||||
| self$panel_scales_y, | ||||||||
| theme, | ||||||||
| self$facet_params | ||||||||
| ) | ||||||||
| # Draw individual panels, then assemble into gtable | ||||||||
| panels <- lapply(seq_along(panels[[1]]), function(i) { | ||||||||
| panel <- lapply(panels, `[[`, i) | ||||||||
| panel <- c(facet_bg[i], panel, facet_fg[i]) | ||||||||
| coord_fg <- self$coord$render_fg(self$panel_params[[i]], theme) | ||||||||
| coord_bg <- self$coord$render_bg(self$panel_params[[i]], theme) | ||||||||
| if (isTRUE(theme$panel.ontop)) { | ||||||||
| panel <- c(panel, list(coord_bg), list(coord_fg)) | ||||||||
| } else { | ||||||||
| panel <- c(list(coord_bg), panel, list(coord_fg)) | ||||||||
| } | ||||||||
| ggname( | ||||||||
| paste("panel", i, sep = "-"), | ||||||||
| gTree(children = do.call("gList", panel)) | ||||||||
| ) | ||||||||
| }) | ||||||||
| plot_table <- self$facet$draw_panels( | ||||||||
| panels, | ||||||||
| self$layout, | ||||||||
| self$panel_scales_x, | ||||||||
| self$panel_scales_y, | ||||||||
| self$panel_params, | ||||||||
| self$coord, | ||||||||
| data, | ||||||||
| theme, | ||||||||
| self$facet_params | ||||||||
| ) | ||||||||
| # Draw individual labels, then add to gtable | ||||||||
| labels <- self$coord$labels(list( | ||||||||
| x = self$xlabel(labels), | ||||||||
| y = self$ylabel(labels) | ||||||||
| )) | ||||||||
| labels <- self$render_labels(labels, theme) | ||||||||
| self$facet$draw_labels( | ||||||||
| plot_table, | ||||||||
| self$layout, | ||||||||
| self$panel_scales_x, | ||||||||
| self$panel_scales_y, | ||||||||
| self$panel_params, | ||||||||
| self$coord, | ||||||||
| data, | ||||||||
| theme, | ||||||||
| labels, | ||||||||
| self$params | ||||||||
| ) | ||||||||
| }, | ||||||||
| train_position = function(self, data, x_scale, y_scale) { | ||||||||
| # Initialise scales if needed, and possible. | ||||||||
| layout <- self$layout | ||||||||
| if (is.null(self$panel_scales_x)) { | ||||||||
| self$panel_scales_x <- self$facet$init_scales(layout, x_scale = x_scale, | ||||||||
| params = self$facet_params)$x | ||||||||
| } | ||||||||
| if (is.null(self$panel_scales_y)) { | ||||||||
| self$panel_scales_y <- self$facet$init_scales(layout, y_scale = y_scale, | ||||||||
| params = self$facet_params)$y | ||||||||
| } | ||||||||
| self$facet$train_scales( | ||||||||
| self$panel_scales_x, | ||||||||
| self$panel_scales_y, | ||||||||
| layout, | ||||||||
| data, | ||||||||
| self$facet_params | ||||||||
| ) | ||||||||
| }, | ||||||||
| map_position = function(self, data) { | ||||||||
| layout <- self$layout | ||||||||
| lapply(data, function(layer_data) { | ||||||||
| match_id <- match(layer_data$PANEL, layout$PANEL) | ||||||||
| # Loop through each variable, mapping across each scale, then joining | ||||||||
| # back together | ||||||||
| x_vars <- intersect(self$panel_scales_x[[1]]$aesthetics, names(layer_data)) | ||||||||
| names(x_vars) <- x_vars | ||||||||
| SCALE_X <- layout$SCALE_X[match_id] | ||||||||
| new_x <- scale_apply(layer_data, x_vars, "map", SCALE_X, self$panel_scales_x) | ||||||||
| layer_data[, x_vars] <- new_x | ||||||||
| y_vars <- intersect(self$panel_scales_y[[1]]$aesthetics, names(layer_data)) | ||||||||
| names(y_vars) <- y_vars | ||||||||
| SCALE_Y <- layout$SCALE_Y[match_id] | ||||||||
| new_y <- scale_apply(layer_data, y_vars, "map", SCALE_Y, self$panel_scales_y) | ||||||||
| layer_data[, y_vars] <- new_y | ||||||||
| layer_data | ||||||||
| }) | ||||||||
| }, | ||||||||
| reset_scales = function(self) { | ||||||||
| if (!self$facet$shrink) return() | ||||||||
| lapply(self$panel_scales_x, function(s) s$reset()) | ||||||||
| lapply(self$panel_scales_y, function(s) s$reset()) | ||||||||
| invisible() | ||||||||
| }, | ||||||||
| finish_data = function(self, data) { | ||||||||
| lapply(data, self$facet$finish_data, | ||||||||
| layout = self$layout, | ||||||||
| x_scales = self$panel_scales_x, | ||||||||
| y_scales = self$panel_scales_y, | ||||||||
| params = self$facet_params | ||||||||
| ) | ||||||||
| }, | ||||||||
| get_scales = function(self, i) { | ||||||||
| this_panel <- self$layout[self$layout$PANEL == i, ] | ||||||||
| list( | ||||||||
| x = self$panel_scales_x[[this_panel$SCALE_X]], | ||||||||
| y = self$panel_scales_y[[this_panel$SCALE_Y]] | ||||||||
| ) | ||||||||
| }, | ||||||||
| setup_panel_params = function(self) { | ||||||||
| # Fudge for CoordFlip and CoordPolar - in place modification of | ||||||||
| # scales is not elegant, but it is pragmatic | ||||||||
| self$coord$modify_scales(self$panel_scales_x, self$panel_scales_y) | ||||||||
| scales_x <- self$panel_scales_x[self$layout$SCALE_X] | ||||||||
| scales_y <- self$panel_scales_y[self$layout$SCALE_Y] | ||||||||
| setup_panel_params <- function(scale_x, scale_y) { | ||||||||
| self$coord$setup_panel_params(scale_x, scale_y, params = self$coord_params) | ||||||||
| } | ||||||||
| self$panel_params <- Map(setup_panel_params, scales_x, scales_y) | ||||||||
| invisible() | ||||||||
| }, | ||||||||
| xlabel = function(self, labels) { | ||||||||
| primary <- self$panel_scales_x[[1]]$name %|W|% labels$x | ||||||||
| primary <- self$panel_scales_x[[1]]$make_title(primary) | ||||||||
| secondary <- if (is.null(self$panel_scales_x[[1]]$secondary.axis)) { | ||||||||
| waiver() | ||||||||
| } else { | ||||||||
| self$panel_scales_x[[1]]$sec_name() | ||||||||
| } %|W|% labels$sec.x | ||||||||
| if (is.derived(secondary)) secondary <- primary | ||||||||
| secondary <- self$panel_scales_x[[1]]$make_sec_title(secondary) | ||||||||
| list(primary = primary, secondary = secondary)[self$panel_scales_x[[1]]$axis_order()] | ||||||||
| }, | ||||||||
| ylabel = function(self, labels) { | ||||||||
| primary <- self$panel_scales_y[[1]]$name %|W|% labels$y | ||||||||
| primary <- self$panel_scales_y[[1]]$make_title(primary) | ||||||||
| secondary <- if (is.null(self$panel_scales_y[[1]]$secondary.axis)) { | ||||||||
| waiver() | ||||||||
| } else { | ||||||||
| self$panel_scales_y[[1]]$sec_name() | ||||||||
| } %|W|% labels$sec.y | ||||||||
| if (is.derived(secondary)) secondary <- primary | ||||||||
| secondary <- self$panel_scales_y[[1]]$make_sec_title(secondary) | ||||||||
| list(primary = primary, secondary = secondary)[self$panel_scales_y[[1]]$axis_order()] | ||||||||
| }, | ||||||||
| render_labels = function(self, labels, theme) { | ||||||||
| label_grobs <- lapply(names(labels), function(label) { | ||||||||
| lapply(c(1, 2), function(i) { | ||||||||
| modify <- if (i == 1) { | ||||||||
| switch(label, x = ".top", y = ".left") | ||||||||
| } else { | ||||||||
| switch(label, x = ".bottom", y = ".right") | ||||||||
| } | ||||||||
| if (is.null(labels[[label]][[i]]) || is.waive(labels[[label]][[i]])) | ||||||||
| return(zeroGrob()) | ||||||||
| element_render( | ||||||||
| theme = theme, | ||||||||
| element = paste0("axis.title.", label, modify), | ||||||||
| label = labels[[label]][[i]], | ||||||||
| margin_x = label == "y", | ||||||||
| margin_y = label == "x" | ||||||||
| ) | ||||||||
| }) | ||||||||
| }) | ||||||||
| names(label_grobs) <- names(labels) | ||||||||
| label_grobs | ||||||||
| } | ||||||||
| ) | ||||||||
| # Helpers ----------------------------------------------------------------- | ||||||||
| # Function for applying scale method to multiple variables in a given | ||||||||
| # data set. Implement in such a way to minimize copying and hence maximise | ||||||||
| # speed | ||||||||
| scale_apply <- function(data, vars, method, scale_id, scales) { | ||||||||
| if (length(vars) == 0) return() | ||||||||
| if (nrow(data) == 0) return() | ||||||||
| n <- length(scales) | ||||||||
| if (any(is.na(scale_id))) stop() | ||||||||
| scale_index <- plyr::split_indices(scale_id, n) | ||||||||
| lapply(vars, function(var) { | ||||||||
| pieces <- lapply(seq_along(scales), function(i) { | ||||||||
| scales[[i]][[method]](data[[var]][scale_index[[i]]]) | ||||||||
| }) | ||||||||
| # Join pieces back together, if necessary | ||||||||
| if (!is.null(pieces)) { | ||||||||
| unlist(pieces)[order(unlist(scale_index))] | ||||||||
| } | ||||||||
| }) | ||||||||
| } | ||||||||
| ggplot2/R/facet-.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' @include ggproto.r | ||||||||
| NULL | ||||||||
| #' @section Facets: | ||||||||
| #' | ||||||||
| #' All `facet_*` functions returns a `Facet` object or an object of a | ||||||||
| #' `Facet` subclass. This object describes how to assign data to different | ||||||||
| #' panels, how to apply positional scales and how to lay out the panels, once | ||||||||
| #' rendered. | ||||||||
| #' | ||||||||
| #' Extending facets can range from the simple modifications of current facets, | ||||||||
| #' to very laborious rewrites with a lot of [gtable()] manipulation. | ||||||||
| #' For some examples of both, please see the extension vignette. | ||||||||
| #' | ||||||||
| #' `Facet` subclasses, like other extendible ggproto classes, have a range | ||||||||
| #' of methods that can be modified. Some of these are required for all new | ||||||||
| #' subclasses, while other only need to be modified if need arises. | ||||||||
| #' | ||||||||
| #' The required methods are: | ||||||||
| #' | ||||||||
| #' - `compute_layout`: Based on layer data compute a mapping between | ||||||||
| #' panels, axes, and potentially other parameters such as faceting variable | ||||||||
| #' level etc. This method must return a data.frame containing at least the | ||||||||
| #' columns `PANEL`, `SCALE_X`, and `SCALE_Y` each containing | ||||||||
| #' integer keys mapping a PANEL to which axes it should use. In addition the | ||||||||
| #' data.frame can contain whatever other information is necessary to assign | ||||||||
| #' observations to the correct panel as well as determining the position of | ||||||||
| #' the panel. | ||||||||
| #' | ||||||||
| #' - `map_data`: This method is supplied the data for each layer in | ||||||||
| #' turn and is expected to supply a `PANEL` column mapping each row to a | ||||||||
| #' panel defined in the layout. Additionally this method can also add or | ||||||||
| #' subtract data points as needed e.g. in the case of adding margins to | ||||||||
| #' `facet_grid`. | ||||||||
| #' | ||||||||
| #' - `draw_panels`: This is where the panels are assembled into a | ||||||||
| #' `gtable` object. The method receives, among others, a list of grobs | ||||||||
| #' defining the content of each panel as generated by the Geoms and Coord | ||||||||
| #' objects. The responsibility of the method is to decorate the panels with | ||||||||
| #' axes and strips as needed, as well as position them relative to each other | ||||||||
| #' in a gtable. For some of the automatic functions to work correctly, each | ||||||||
| #' panel, axis, and strip grob name must be prefixed with "panel", "axis", and | ||||||||
| #' "strip" respectively. | ||||||||
| #' | ||||||||
| #' In addition to the methods described above, it is also possible to override | ||||||||
| #' the default behaviour of one or more of the following methods: | ||||||||
| #' | ||||||||
| #' - `setup_params`: | ||||||||
| #' - `init_scales`: Given a master scale for x and y, create panel | ||||||||
| #' specific scales for each panel defined in the layout. The default is to | ||||||||
| #' simply clone the master scale. | ||||||||
| #' | ||||||||
| #' - `train_scales`: Based on layer data train each set of panel | ||||||||
| #' scales. The default is to train it on the data related to the panel. | ||||||||
| #' | ||||||||
| #' - `finish_data`: Make last-minute modifications to layer data | ||||||||
| #' before it is rendered by the Geoms. The default is to not modify it. | ||||||||
| #' | ||||||||
| #' - `draw_back`: Add a grob in between the background defined by the | ||||||||
| #' Coord object (usually the axis grid) and the layer stack. The default is to | ||||||||
| #' return an empty grob for each panel. | ||||||||
| #' | ||||||||
| #' - `draw_front`: As above except the returned grob is placed | ||||||||
| #' between the layer stack and the foreground defined by the Coord object | ||||||||
| #' (usually empty). The default is, as above, to return an empty grob. | ||||||||
| #' | ||||||||
| #' - `draw_labels`: Given the gtable returned by `draw_panels`, | ||||||||
| #' add axis titles to the gtable. The default is to add one title at each side | ||||||||
| #' depending on the position and existence of axes. | ||||||||
| #' | ||||||||
| #' All extension methods receive the content of the params field as the params | ||||||||
| #' argument, so the constructor function will generally put all relevant | ||||||||
| #' information into this field. The only exception is the `shrink` | ||||||||
| #' parameter which is used to determine if scales are retrained after Stat | ||||||||
| #' transformations has been applied. | ||||||||
| #' | ||||||||
| #' @rdname ggplot2-ggproto | ||||||||
| #' @format NULL | ||||||||
| #' @usage NULL | ||||||||
| #' @export | ||||||||
| Facet <- ggproto("Facet", NULL, | ||||||||
| shrink = FALSE, | ||||||||
| params = list(), | ||||||||
| compute_layout = function(data, params) { | ||||||||
| stop("Not implemented", call. = FALSE) | ||||||||
| }, | ||||||||
| map_data = function(data, layout, params) { | ||||||||
| stop("Not implemented", call. = FALSE) | ||||||||
| }, | ||||||||
| init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) { | ||||||||
| scales <- list() | ||||||||
| if (!is.null(x_scale)) { | ||||||||
| scales$x <- plyr::rlply(max(layout$SCALE_X), x_scale$clone()) | ||||||||
| } | ||||||||
| if (!is.null(y_scale)) { | ||||||||
| scales$y <- plyr::rlply(max(layout$SCALE_Y), y_scale$clone()) | ||||||||
| } | ||||||||
| scales | ||||||||
| }, | ||||||||
| train_scales = function(x_scales, y_scales, layout, data, params) { | ||||||||
| # loop over each layer, training x and y scales in turn | ||||||||
| for (layer_data in data) { | ||||||||
| match_id <- match(layer_data$PANEL, layout$PANEL) | ||||||||
| if (!is.null(x_scales)) { | ||||||||
| x_vars <- intersect(x_scales[[1]]$aesthetics, names(layer_data)) | ||||||||
| SCALE_X <- layout$SCALE_X[match_id] | ||||||||
| scale_apply(layer_data, x_vars, "train", SCALE_X, x_scales) | ||||||||
| } | ||||||||
| if (!is.null(y_scales)) { | ||||||||
| y_vars <- intersect(y_scales[[1]]$aesthetics, names(layer_data)) | ||||||||
| SCALE_Y <- layout$SCALE_Y[match_id] | ||||||||
| scale_apply(layer_data, y_vars, "train", SCALE_Y, y_scales) | ||||||||
| } | ||||||||
| } | ||||||||
| }, | ||||||||
| draw_back = function(data, layout, x_scales, y_scales, theme, params) { | ||||||||
| rep(list(zeroGrob()), length(unique(layout$PANEL))) | ||||||||
| }, | ||||||||
| draw_front = function(data, layout, x_scales, y_scales, theme, params) { | ||||||||
| rep(list(zeroGrob()), length(unique(layout$PANEL))) | ||||||||
| }, | ||||||||
| draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { | ||||||||
| stop("Not implemented", call. = FALSE) | ||||||||
| }, | ||||||||
| draw_labels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, labels, params) { | ||||||||
| panel_dim <- find_panel(panels) | ||||||||
| xlab_height_top <- grobHeight(labels$x[[1]]) | ||||||||
| panels <- gtable_add_rows(panels, xlab_height_top, pos = 0) | ||||||||
| panels <- gtable_add_grob(panels, labels$x[[1]], name = "xlab-t", | ||||||||
| l = panel_dim$l, r = panel_dim$r, t = 1, clip = "off") | ||||||||
| xlab_height_bottom <- grobHeight(labels$x[[2]]) | ||||||||
| panels <- gtable_add_rows(panels, xlab_height_bottom, pos = -1) | ||||||||
| panels <- gtable_add_grob(panels, labels$x[[2]], name = "xlab-b", | ||||||||
| l = panel_dim$l, r = panel_dim$r, t = -1, clip = "off") | ||||||||
| panel_dim <- find_panel(panels) | ||||||||
| ylab_width_left <- grobWidth(labels$y[[1]]) | ||||||||
| panels <- gtable_add_cols(panels, ylab_width_left, pos = 0) | ||||||||
| panels <- gtable_add_grob(panels, labels$y[[1]], name = "ylab-l", | ||||||||
| l = 1, b = panel_dim$b, t = panel_dim$t, clip = "off") | ||||||||
| ylab_width_right <- grobWidth(labels$y[[2]]) | ||||||||
| panels <- gtable_add_cols(panels, ylab_width_right, pos = -1) | ||||||||
| panels <- gtable_add_grob(panels, labels$y[[2]], name = "ylab-r", | ||||||||
| l = -1, b = panel_dim$b, t = panel_dim$t, clip = "off") | ||||||||
| panels | ||||||||
| }, | ||||||||
| setup_params = function(data, params) { | ||||||||
| params | ||||||||
| }, | ||||||||
| setup_data = function(data, params) { | ||||||||
| data | ||||||||
| }, | ||||||||
| finish_data = function(data, layout, x_scales, y_scales, params) { | ||||||||
| data | ||||||||
| }, | ||||||||
| vars = function() { | ||||||||
| character(0) | ||||||||
| } | ||||||||
| ) | ||||||||
| # Helpers ----------------------------------------------------------------- | ||||||||
| #' Quote faceting variables | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' Just like [aes()], `vars()` is a [quoting function][rlang::quotation] | ||||||||
| #' that takes inputs to be evaluated in the context of a dataset. | ||||||||
| #' These inputs can be: | ||||||||
| #' | ||||||||
| #' * variable names | ||||||||
| #' * complex expressions | ||||||||
| #' | ||||||||
| #' In both cases, the results (the vectors that the variable | ||||||||
| #' represents or the results of the expressions) are used to form | ||||||||
| #' faceting groups. | ||||||||
| #' | ||||||||
| #' @param ... Variables or expressions automatically quoted. These are | ||||||||
| #' evaluated in the context of the data to form faceting groups. Can | ||||||||
| #' be named (the names are passed to a [labeller][labellers]). | ||||||||
| #' | ||||||||
| #' @seealso [aes()], [facet_wrap()], [facet_grid()] | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' p <- ggplot(mtcars, aes(wt, disp)) + geom_point() | ||||||||
| #' p + facet_wrap(vars(vs, am)) | ||||||||
| #' | ||||||||
| #' # vars() makes it easy to pass variables from wrapper functions: | ||||||||
| #' wrap_by <- function(...) { | ||||||||
| #' facet_wrap(vars(...), labeller = label_both) | ||||||||
| #' } | ||||||||
| #' p + wrap_by(vs) | ||||||||
| #' p + wrap_by(vs, am) | ||||||||
| #' | ||||||||
| #' # You can also supply expressions to vars(). In this case it's often a | ||||||||
| #' # good idea to supply a name as well: | ||||||||
| #' p + wrap_by(drat = cut_number(drat, 3)) | ||||||||
| #' | ||||||||
| #' # Let's create another function for cutting and wrapping a | ||||||||
| #' # variable. This time it will take a named argument instead of dots, | ||||||||
| #' # so we'll have to use the "enquote and unquote" pattern: | ||||||||
| #' wrap_cut <- function(var, n = 3) { | ||||||||
| #' # Let's enquote the named argument `var` to make it auto-quoting: | ||||||||
| #' var <- enquo(var) | ||||||||
| #' | ||||||||
| #' # `quo_name()` will create a nice default name: | ||||||||
| #' nm <- quo_name(var) | ||||||||
| #' | ||||||||
| #' # Now let's unquote everything at the right place. Note that we also | ||||||||
| #' # unquote `n` just in case the data frame has a column named | ||||||||
| #' # `n`. The latter would have precedence over our local variable | ||||||||
| #' # because the data is always masking the environment. | ||||||||
| #' wrap_by(!!nm := cut_number(!!var, !!n)) | ||||||||
| #' } | ||||||||
| #' | ||||||||
| #' # Thanks to tidy eval idioms we now have another useful wrapper: | ||||||||
| #' p + wrap_cut(drat) | ||||||||
| vars <- function(...) { | ||||||||
| rlang::quos(...) | ||||||||
| } | ||||||||
| #' Is this object a faceting specification? | ||||||||
| #' | ||||||||
| #' @param x object to test | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| is.facet <- function(x) inherits(x, "Facet") | ||||||||
| # A "special" value, currently not used but could be used to determine | ||||||||
| # if faceting is active | ||||||||
| NO_PANEL <- -1L | ||||||||
| unique_combs <- function(df) { | ||||||||
| if (length(df) == 0) return() | ||||||||
| unique_values <- plyr::llply(df, ulevels) | ||||||||
| rev(expand.grid(rev(unique_values), stringsAsFactors = FALSE, | ||||||||
| KEEP.OUT.ATTRS = TRUE)) | ||||||||
| } | ||||||||
| df.grid <- function(a, b) { | ||||||||
| if (is.null(a) || nrow(a) == 0) return(b) | ||||||||
| if (is.null(b) || nrow(b) == 0) return(a) | ||||||||
| indexes <- expand.grid( | ||||||||
| i_a = seq_len(nrow(a)), | ||||||||
| i_b = seq_len(nrow(b)) | ||||||||
| ) | ||||||||
| plyr::unrowname(cbind( | ||||||||
| a[indexes$i_a, , drop = FALSE], | ||||||||
| b[indexes$i_b, , drop = FALSE] | ||||||||
| )) | ||||||||
| } | ||||||||
| # A facets spec is a list of facets. A grid facetting needs two facets | ||||||||
| # while a wrap facetting flattens all dimensions and thus accepts any | ||||||||
| # number of facets. | ||||||||
| # | ||||||||
| # A facets is a list of grouping variables. They are typically | ||||||||
| # supplied as variable names but can be expressions. | ||||||||
| # | ||||||||
| # as_facets() is complex due to historical baggage but its main | ||||||||
| # purpose is to create a facets spec from a formula: a + b ~ c + d | ||||||||
| # creates a facets list with two components, each of which bundles two | ||||||||
| # facetting variables. | ||||||||
| as_facets_list <- function(x) { | ||||||||
| if (inherits(x, "mapping")) { | ||||||||
| stop("Please use `vars()` to supply facet variables") | ||||||||
| } | ||||||||
| if (inherits(x, "quosures")) { | ||||||||
| x <- rlang::quos_auto_name(x) | ||||||||
| return(list(x)) | ||||||||
| } | ||||||||
| # This needs to happen early because we might get a formula. | ||||||||
| # facet_grid() directly converted strings to a formula while | ||||||||
| # facet_wrap() called as.quoted(). Hence this is a little more | ||||||||
| # complicated for backward compatibility. | ||||||||
| if (rlang::is_string(x)) { | ||||||||
| x <- rlang::parse_expr(x) | ||||||||
| } | ||||||||
| # At this level formulas are coerced to lists of lists for backward | ||||||||
| # compatibility with facet_grid(). The LHS and RHS are treated as | ||||||||
| # distinct facet dimensions and `+` defines multiple facet variables | ||||||||
| # inside each dimension. | ||||||||
| if (rlang::is_formula(x)) { | ||||||||
| return(f_as_facets_list(x)) | ||||||||
| } | ||||||||
| # For backward-compatibility with facet_wrap() | ||||||||
| if (!rlang::is_bare_list(x)) { | ||||||||
| x <- as_quoted(x) | ||||||||
| } | ||||||||
| # If we have a list there are two possibilities. We may already have | ||||||||
| # a proper facet spec structure. Otherwise we coerce each element | ||||||||
| # with as_quoted() for backward compatibility with facet_grid(). | ||||||||
| if (is.list(x)) { | ||||||||
| x <- lapply(x, as_facets) | ||||||||
| } | ||||||||
| if (sum(vapply(x, length, integer(1))) == 0L) { | ||||||||
| stop("Must specify at least one variable to facet by", call. = FALSE) | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| # Compatibility with plyr::as.quoted() | ||||||||
| as_quoted <- function(x) { | ||||||||
| if (is.character(x)) { | ||||||||
| if (length(x) > 1) { | ||||||||
| x <- paste(x, collapse = "; ") | ||||||||
| } | ||||||||
| return(rlang::parse_exprs(x)) | ||||||||
| } | ||||||||
| if (is.null(x)) { | ||||||||
| return(list()) | ||||||||
| } | ||||||||
| if (rlang::is_formula(x)) { | ||||||||
| return(simplify(x)) | ||||||||
| } | ||||||||
| list(x) | ||||||||
| } | ||||||||
| # From plyr:::as.quoted.formula | ||||||||
| simplify <- function(x) { | ||||||||
| if (length(x) == 2 && rlang::is_symbol(x[[1]], "~")) { | ||||||||
| return(simplify(x[[2]])) | ||||||||
| } | ||||||||
| if (length(x) < 3) { | ||||||||
| return(list(x)) | ||||||||
| } | ||||||||
| op <- x[[1]]; a <- x[[2]]; b <- x[[3]] | ||||||||
| if (rlang::is_symbol(op, c("+", "*", "~"))) { | ||||||||
| c(simplify(a), simplify(b)) | ||||||||
| } else if (rlang::is_symbol(op, "-")) { | ||||||||
| c(simplify(a), expr(-!!simplify(b))) | ||||||||
| } else { | ||||||||
| list(x) | ||||||||
| } | ||||||||
| } | ||||||||
| f_as_facets_list <- function(f) { | ||||||||
| lhs <- function(x) if (length(x) == 2) NULL else x[-3] | ||||||||
| rhs <- function(x) if (length(x) == 2) x else x[-2] | ||||||||
| rows <- f_as_facets(lhs(f)) | ||||||||
| cols <- f_as_facets(rhs(f)) | ||||||||
| if (length(rows) + length(cols) == 0) { | ||||||||
| stop("Must specify at least one variable to facet by", call. = FALSE) | ||||||||
| } | ||||||||
| if (length(rows)) { | ||||||||
| list(rows, cols) | ||||||||
| } else { | ||||||||
| list(cols) | ||||||||
| } | ||||||||
| } | ||||||||
| as_facets <- function(x) { | ||||||||
| if (is_facets(x)) { | ||||||||
| return(x) | ||||||||
| } | ||||||||
| if (rlang::is_formula(x)) { | ||||||||
| # Use different formula method because plyr's does not handle the | ||||||||
| # environment correctly. | ||||||||
| f_as_facets(x) | ||||||||
| } else { | ||||||||
| vars <- as_quoted(x) | ||||||||
| as_quosures(vars, globalenv(), named = TRUE) | ||||||||
| } | ||||||||
| } | ||||||||
| f_as_facets <- function(f) { | ||||||||
| if (is.null(f)) { | ||||||||
| return(as_quosures(list())) | ||||||||
| } | ||||||||
| env <- rlang::f_env(f) %||% globalenv() | ||||||||
| # as.quoted() handles `+` specifications | ||||||||
| vars <- plyr::as.quoted(f) | ||||||||
| # `.` in formulas is ignored | ||||||||
| vars <- discard_dots(vars) | ||||||||
| as_quosures(vars, env, named = TRUE) | ||||||||
| } | ||||||||
| discard_dots <- function(x) { | ||||||||
| x[!vapply(x, identical, logical(1), as.name("."))] | ||||||||
| } | ||||||||
| is_facets <- function(x) { | ||||||||
| if (!is.list(x)) { | ||||||||
| return(FALSE) | ||||||||
| } | ||||||||
| if (!length(x)) { | ||||||||
| return(FALSE) | ||||||||
| } | ||||||||
| all(vapply(x, rlang::is_quosure, logical(1))) | ||||||||
| } | ||||||||
| # When evaluating variables in a facet specification, we evaluate bare | ||||||||
| # variables and expressions slightly differently. Bare variables should | ||||||||
| # always succeed, even if the variable doesn't exist in the data frame: | ||||||||
| # that makes it possible to repeat data across multiple factors. But | ||||||||
| # when evaluating an expression, you want to see any errors. That does | ||||||||
| # mean you can't have background data when faceting by an expression, | ||||||||
| # but that seems like a reasonable tradeoff. | ||||||||
| eval_facets <- function(facets, data, env = globalenv()) { | ||||||||
| vars <- compact(lapply(facets, eval_facet, data, env = env)) | ||||||||
| tibble::as_tibble(vars) | ||||||||
| } | ||||||||
| eval_facet <- function(facet, data, env = emptyenv()) { | ||||||||
| if (rlang::quo_is_symbol(facet)) { | ||||||||
| facet <- as.character(rlang::quo_get_expr(facet)) | ||||||||
| if (facet %in% names(data)) { | ||||||||
| out <- data[[facet]] | ||||||||
| } else { | ||||||||
| out <- NULL | ||||||||
| } | ||||||||
| return(out) | ||||||||
| } | ||||||||
| rlang::eval_tidy(facet, data, env) | ||||||||
| } | ||||||||
| layout_null <- function() { | ||||||||
| # PANEL needs to be a factor to be consistent with other facet types | ||||||||
| new_data_frame(PANEL = factor(1), ROW = 1, COL = 1, SCALE_X = 1, SCALE_Y = 1) | ||||||||
| } | ||||||||
| check_layout <- function(x) { | ||||||||
| if (all(c("PANEL", "SCALE_X", "SCALE_Y") %in% names(x))) { | ||||||||
| return() | ||||||||
| } | ||||||||
| stop( | ||||||||
| "Facet layout has bad format. ", | ||||||||
| "It must contain columns 'PANEL', 'SCALE_X', and 'SCALE_Y'", | ||||||||
| call. = FALSE | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Get the maximal width/length of a list of grobs | ||||||||
| #' | ||||||||
| #' @param grobs A list of grobs | ||||||||
| #' | ||||||||
| #' @return The largest value. measured in cm as a unit object | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| max_height <- function(grobs) { | ||||||||
| unit(max(unlist(lapply(grobs, height_cm))), "cm") | ||||||||
| } | ||||||||
| #' @rdname max_height | ||||||||
| #' @export | ||||||||
| max_width <- function(grobs) { | ||||||||
| unit(max(unlist(lapply(grobs, width_cm))), "cm") | ||||||||
| } | ||||||||
| #' Find panels in a gtable | ||||||||
| #' | ||||||||
| #' These functions help detect the placement of panels in a gtable, if they are | ||||||||
| #' named with "panel" in the beginning. `find_panel` returns the extend of | ||||||||
| #' the panel area, while `panel_cols` and `panel_rows` returns the | ||||||||
| #' columns and rows that contains panels respectively. | ||||||||
| #' | ||||||||
| #' @param table A gtable | ||||||||
| #' | ||||||||
| #' @return A data.frame with some or all of the columns t(op), r(ight), | ||||||||
| #' b(ottom), and l(eft) | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| find_panel <- function(table) { | ||||||||
| layout <- table$layout | ||||||||
| panels <- layout[grepl("^panel", layout$name), , drop = FALSE] | ||||||||
| new_data_frame( | ||||||||
| t = min(panels$t), | ||||||||
| r = max(panels$r), | ||||||||
| b = max(panels$b), | ||||||||
| l = min(panels$l) | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @rdname find_panel | ||||||||
| #' @export | ||||||||
| panel_cols = function(table) { | ||||||||
| panels <- table$layout[grepl("^panel", table$layout$name), , drop = FALSE] | ||||||||
| unique(panels[, c('l', 'r')]) | ||||||||
| } | ||||||||
| #' @rdname find_panel | ||||||||
| #' @export | ||||||||
| panel_rows <- function(table) { | ||||||||
| panels <- table$layout[grepl("^panel", table$layout$name), , drop = FALSE] | ||||||||
| unique(panels[, c('t', 'b')]) | ||||||||
| } | ||||||||
| #' Take input data and define a mapping between faceting variables and ROW, | ||||||||
| #' COL and PANEL keys | ||||||||
| #' | ||||||||
| #' @param data A list of data.frames, the first being the plot data and the | ||||||||
| #' subsequent individual layer data | ||||||||
| #' @param env The environment the vars should be evaluated in | ||||||||
| #' @param vars A list of quoted symbols matching columns in data | ||||||||
| #' @param drop should missing combinations/levels be dropped | ||||||||
| #' | ||||||||
| #' @return A data.frame with columns for PANEL, ROW, COL, and faceting vars | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| combine_vars <- function(data, env = emptyenv(), vars = NULL, drop = TRUE) { | ||||||||
| if (length(vars) == 0) return(new_data_frame()) | ||||||||
| # For each layer, compute the facet values | ||||||||
| values <- compact(plyr::llply(data, eval_facets, facets = vars, env = env)) | ||||||||
| # Form the base data.frame which contains all combinations of faceting | ||||||||
| # variables that appear in the data | ||||||||
| has_all <- unlist(lapply(values, length)) == length(vars) | ||||||||
| if (!any(has_all)) { | ||||||||
| missing <- lapply(values, function(x) setdiff(names(vars), names(x))) | ||||||||
| missing_txt <- vapply(missing, var_list, character(1)) | ||||||||
| name <- c("Plot", paste0("Layer ", seq_len(length(data) - 1))) | ||||||||
| stop( | ||||||||
| "At least one layer must contain all faceting variables: ", | ||||||||
| var_list(names(vars)), ".\n", | ||||||||
| paste0("* ", name, " is missing ", missing_txt, collapse = "\n"), | ||||||||
| call. = FALSE | ||||||||
| ) | ||||||||
| } | ||||||||
| base <- unique(plyr::ldply(values[has_all])) | ||||||||
| if (!drop) { | ||||||||
| base <- unique_combs(base) | ||||||||
| } | ||||||||
| # Systematically add on missing combinations | ||||||||
| for (value in values[!has_all]) { | ||||||||
| if (empty(value)) next; | ||||||||
| old <- base[setdiff(names(base), names(value))] | ||||||||
| new <- unique(value[intersect(names(base), names(value))]) | ||||||||
| if (drop) { | ||||||||
| new <- unique_combs(new) | ||||||||
| } | ||||||||
| base <- rbind(base, df.grid(old, new)) | ||||||||
| } | ||||||||
| if (empty(base)) { | ||||||||
| stop("Faceting variables must have at least one value", call. = FALSE) | ||||||||
| } | ||||||||
| base | ||||||||
| } | ||||||||
| #' Render panel axes | ||||||||
| #' | ||||||||
| #' These helpers facilitates generating theme compliant axes when | ||||||||
| #' building up the plot. | ||||||||
| #' | ||||||||
| #' @param x,y A list of ranges as available to the draw_panel method in | ||||||||
| #' `Facet` subclasses. | ||||||||
| #' @param coord A `Coord` object | ||||||||
| #' @param theme A `theme` object | ||||||||
| #' @param transpose Should the output be transposed? | ||||||||
| #' | ||||||||
| #' @return A list with the element "x" and "y" each containing axis | ||||||||
| #' specifications for the ranges passed in. Each axis specification is a list | ||||||||
| #' with a "top" and "bottom" element for x-axes and "left" and "right" element | ||||||||
| #' for y-axis, holding the respective axis grobs. Depending on the content of x | ||||||||
| #' and y some of the grobs might be zeroGrobs. If `transpose=TRUE` the | ||||||||
| #' content of the x and y elements will be transposed so e.g. all left-axes are | ||||||||
| #' collected in a left element as a list of grobs. | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| #' | ||||||||
| render_axes <- function(x = NULL, y = NULL, coord, theme, transpose = FALSE) { | ||||||||
| axes <- list() | ||||||||
| if (!is.null(x)) { | ||||||||
| axes$x <- lapply(x, coord$render_axis_h, theme) | ||||||||
| } | ||||||||
| if (!is.null(y)) { | ||||||||
| axes$y <- lapply(y, coord$render_axis_v, theme) | ||||||||
| } | ||||||||
| if (transpose) { | ||||||||
| axes <- list( | ||||||||
| x = list( | ||||||||
| top = lapply(axes$x, `[[`, "top"), | ||||||||
| bottom = lapply(axes$x, `[[`, "bottom") | ||||||||
| ), | ||||||||
| y = list( | ||||||||
| left = lapply(axes$y, `[[`, "left"), | ||||||||
| right = lapply(axes$y, `[[`, "right") | ||||||||
| ) | ||||||||
| ) | ||||||||
| } | ||||||||
| axes | ||||||||
| } | ||||||||
| #' Render panel strips | ||||||||
| #' | ||||||||
| #' All positions are rendered and it is up to the facet to decide which to use | ||||||||
| #' | ||||||||
| #' @param x,y A data.frame with a column for each variable and a row for each | ||||||||
| #' combination to draw | ||||||||
| #' @param labeller A labeller function | ||||||||
| #' @param theme a `theme` object | ||||||||
| #' | ||||||||
| #' @return A list with an "x" and a "y" element, each containing a "top" and | ||||||||
| #' "bottom" or "left" and "right" element respectively. These contains a list of | ||||||||
| #' rendered strips as gtables. | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| render_strips <- function(x = NULL, y = NULL, labeller, theme) { | ||||||||
| list( | ||||||||
| x = build_strip(x, labeller, theme, TRUE), | ||||||||
| y = build_strip(y, labeller, theme, FALSE) | ||||||||
| ) | ||||||||
| } | ||||||||
| ggplot2/R/facet-grid-.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' @include facet-.r | ||||||||
| NULL | ||||||||
| #' Lay out panels in a grid | ||||||||
| #' | ||||||||
| #' `facet_grid()` forms a matrix of panels defined by row and column | ||||||||
| #' faceting variables. It is most useful when you have two discrete | ||||||||
| #' variables, and all combinations of the variables exist in the data. | ||||||||
| #' | ||||||||
| #' @param rows,cols A set of variables or expressions quoted by | ||||||||
| #' [vars()] and defining faceting groups on the rows or columns | ||||||||
| #' dimension. The variables can be named (the names are passed to | ||||||||
| #' `labeller`). | ||||||||
| #' | ||||||||
| #' For compatibility with the classic interface, `rows` can also be | ||||||||
| #' a formula with the rows (of the tabular display) on the LHS and | ||||||||
| #' the columns (of the tabular display) on the RHS; the dot in the | ||||||||
| #' formula is used to indicate there should be no faceting on this | ||||||||
| #' dimension (either row or column). | ||||||||
| #' @param scales Are scales shared across all facets (the default, | ||||||||
| #' `"fixed"`), or do they vary across rows (`"free_x"`), | ||||||||
| #' columns (`"free_y"`), or both rows and columns (`"free"`)? | ||||||||
| #' @param space If `"fixed"`, the default, all panels have the same size. | ||||||||
| #' If `"free_y"` their height will be proportional to the length of the | ||||||||
| #' y scale; if `"free_x"` their width will be proportional to the | ||||||||
| #' length of the x scale; or if `"free"` both height and width will | ||||||||
| #' vary. This setting has no effect unless the appropriate scales also vary. | ||||||||
| #' @param labeller A function that takes one data frame of labels and | ||||||||
| #' returns a list or data frame of character vectors. Each input | ||||||||
| #' column corresponds to one factor. Thus there will be more than | ||||||||
| #' one with formulae of the type `~cyl + am`. Each output | ||||||||
| #' column gets displayed as one separate line in the strip | ||||||||
| #' label. This function should inherit from the "labeller" S3 class | ||||||||
| #' for compatibility with [labeller()]. See | ||||||||
| #' [label_value()] for more details and pointers to other | ||||||||
| #' options. | ||||||||
| #' @param as.table If `TRUE`, the default, the facets are laid out like | ||||||||
| #' a table with highest values at the bottom-right. If `FALSE`, the | ||||||||
| #' facets are laid out like a plot with the highest value at the top-right. | ||||||||
| #' @param switch By default, the labels are displayed on the top and | ||||||||
| #' right of the plot. If `"x"`, the top labels will be | ||||||||
| #' displayed to the bottom. If `"y"`, the right-hand side | ||||||||
| #' labels will be displayed to the left. Can also be set to | ||||||||
| #' `"both"`. | ||||||||
| #' @param shrink If `TRUE`, will shrink scales to fit output of | ||||||||
| #' statistics, not raw data. If `FALSE`, will be range of raw data | ||||||||
| #' before statistical summary. | ||||||||
| #' @param drop If `TRUE`, the default, all factor levels not used in the | ||||||||
| #' data will automatically be dropped. If `FALSE`, all factor levels | ||||||||
| #' will be shown, regardless of whether or not they appear in the data. | ||||||||
| #' @param margins Either a logical value or a character | ||||||||
| #' vector. Margins are additional facets which contain all the data | ||||||||
| #' for each of the possible values of the faceting variables. If | ||||||||
| #' `FALSE`, no additional facets are included (the | ||||||||
| #' default). If `TRUE`, margins are included for all faceting | ||||||||
| #' variables. If specified as a character vector, it is the names of | ||||||||
| #' variables for which margins are to be created. | ||||||||
| #' @param facets This argument is soft-deprecated, please us `rows` | ||||||||
| #' and `cols` instead. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' p <- ggplot(mpg, aes(displ, cty)) + geom_point() | ||||||||
| #' | ||||||||
| #' # Use vars() to supply variables from the dataset: | ||||||||
| #' p + facet_grid(rows = vars(drv)) | ||||||||
| #' p + facet_grid(cols = vars(cyl)) | ||||||||
| #' p + facet_grid(vars(drv), vars(cyl)) | ||||||||
| #' | ||||||||
| #' # The historical formula interface is also available: | ||||||||
| #' \donttest{ | ||||||||
| #' p + facet_grid(. ~ cyl) | ||||||||
| #' p + facet_grid(drv ~ .) | ||||||||
| #' p + facet_grid(drv ~ cyl) | ||||||||
| #' } | ||||||||
| #' | ||||||||
| #' # To change plot order of facet grid, | ||||||||
| #' # change the order of variable levels with factor() | ||||||||
| #' | ||||||||
| #' # If you combine a facetted dataset with a dataset that lacks those | ||||||||
| #' # faceting variables, the data will be repeated across the missing | ||||||||
| #' # combinations: | ||||||||
| #' df <- data.frame(displ = mean(mpg$displ), cty = mean(mpg$cty)) | ||||||||
| #' p + | ||||||||
| #' facet_grid(cols = vars(cyl)) + | ||||||||
| #' geom_point(data = df, colour = "red", size = 2) | ||||||||
| #' | ||||||||
| #' # Free scales ------------------------------------------------------- | ||||||||
| #' # You can also choose whether the scales should be constant | ||||||||
| #' # across all panels (the default), or whether they should be allowed | ||||||||
| #' # to vary | ||||||||
| #' mt <- ggplot(mtcars, aes(mpg, wt, colour = factor(cyl))) + | ||||||||
| #' geom_point() | ||||||||
| #' | ||||||||
| #' mt + facet_grid(. ~ cyl, scales = "free") | ||||||||
| #' | ||||||||
| #' # If scales and space are free, then the mapping between position | ||||||||
| #' # and values in the data will be the same across all panels. This | ||||||||
| #' # is particularly useful for categorical axes | ||||||||
| #' ggplot(mpg, aes(drv, model)) + | ||||||||
| #' geom_point() + | ||||||||
| #' facet_grid(manufacturer ~ ., scales = "free", space = "free") + | ||||||||
| #' theme(strip.text.y = element_text(angle = 0)) | ||||||||
| #' | ||||||||
| #' # Margins ---------------------------------------------------------- | ||||||||
| #' \donttest{ | ||||||||
| #' # Margins can be specified logically (all yes or all no) or for specific | ||||||||
| #' # variables as (character) variable names | ||||||||
| #' mg <- ggplot(mtcars, aes(x = mpg, y = wt)) + geom_point() | ||||||||
| #' mg + facet_grid(vs + am ~ gear, margins = TRUE) | ||||||||
| #' mg + facet_grid(vs + am ~ gear, margins = "am") | ||||||||
| #' # when margins are made over "vs", since the facets for "am" vary | ||||||||
| #' # within the values of "vs", the marginal facet for "vs" is also | ||||||||
| #' # a margin over "am". | ||||||||
| #' mg + facet_grid(vs + am ~ gear, margins = "vs") | ||||||||
| #' } | ||||||||
| facet_grid <- function(rows = NULL, cols = NULL, scales = "fixed", | ||||||||
| space = "fixed", shrink = TRUE, | ||||||||
| labeller = "label_value", as.table = TRUE, | ||||||||
| switch = NULL, drop = TRUE, margins = FALSE, | ||||||||
| facets = NULL) { | ||||||||
| # `facets` is soft-deprecated and renamed to `rows` | ||||||||
| if (!is.null(facets)) { | ||||||||
| rows <- facets | ||||||||
| } | ||||||||
| # Should become a warning in a future release | ||||||||
| if (is.logical(cols)) { | ||||||||
| margins <- cols | ||||||||
| cols <- NULL | ||||||||
| } | ||||||||
| scales <- match.arg(scales, c("fixed", "free_x", "free_y", "free")) | ||||||||
| free <- list( | ||||||||
| x = any(scales %in% c("free_x", "free")), | ||||||||
| y = any(scales %in% c("free_y", "free")) | ||||||||
| ) | ||||||||
| space <- match.arg(space, c("fixed", "free_x", "free_y", "free")) | ||||||||
| space_free <- list( | ||||||||
| x = any(space %in% c("free_x", "free")), | ||||||||
| y = any(space %in% c("free_y", "free")) | ||||||||
| ) | ||||||||
| if (!is.null(switch) && !switch %in% c("both", "x", "y")) { | ||||||||
| stop("switch must be either 'both', 'x', or 'y'", call. = FALSE) | ||||||||
| } | ||||||||
| facets_list <- grid_as_facets_list(rows, cols) | ||||||||
| n <- length(facets_list) | ||||||||
| if (n > 2L) { | ||||||||
| stop("A grid facet specification can't have more than two dimensions", call. = FALSE) | ||||||||
| } | ||||||||
| if (n == 1L) { | ||||||||
| rows <- quos() | ||||||||
| cols <- facets_list[[1]] | ||||||||
| } else { | ||||||||
| rows <- facets_list[[1]] | ||||||||
| cols <- facets_list[[2]] | ||||||||
| } | ||||||||
| # Check for deprecated labellers | ||||||||
| labeller <- check_labeller(labeller) | ||||||||
| ggproto(NULL, FacetGrid, | ||||||||
| shrink = shrink, | ||||||||
| params = list(rows = rows, cols = cols, margins = margins, | ||||||||
| free = free, space_free = space_free, labeller = labeller, | ||||||||
| as.table = as.table, switch = switch, drop = drop) | ||||||||
| ) | ||||||||
| } | ||||||||
| grid_as_facets_list <- function(rows, cols) { | ||||||||
| is_rows_vars <- is.null(rows) || rlang::is_quosures(rows) | ||||||||
| if (!is_rows_vars) { | ||||||||
| if (!is.null(cols)) { | ||||||||
| stop("`rows` must be `NULL` or a `vars()` list if `cols` is a `vars()` list", call. = FALSE) | ||||||||
| } | ||||||||
| return(as_facets_list(rows)) | ||||||||
| } | ||||||||
| is_cols_vars <- is.null(cols) || rlang::is_quosures(cols) | ||||||||
| if (!is_cols_vars) { | ||||||||
| stop("`cols` must be `NULL` or a `vars()` specification", call. = FALSE) | ||||||||
| } | ||||||||
| if (is.null(rows)) { | ||||||||
| rows <- quos() | ||||||||
| } else { | ||||||||
| rows <- rlang::quos_auto_name(rows) | ||||||||
| } | ||||||||
| if (is.null(cols)) { | ||||||||
| cols <- quos() | ||||||||
| } else { | ||||||||
| cols <- rlang::quos_auto_name(cols) | ||||||||
| } | ||||||||
| list(rows, cols) | ||||||||
| } | ||||||||
| #' @rdname ggplot2-ggproto | ||||||||
| #' @format NULL | ||||||||
| #' @usage NULL | ||||||||
| #' @export | ||||||||
| FacetGrid <- ggproto("FacetGrid", Facet, | ||||||||
| shrink = TRUE, | ||||||||
| compute_layout = function(data, params) { | ||||||||
| rows <- params$rows | ||||||||
| cols <- params$cols | ||||||||
| dups <- intersect(names(rows), names(cols)) | ||||||||
| if (length(dups) > 0) { | ||||||||
| stop( | ||||||||
| "Faceting variables can only appear in row or cols, not both.\n", | ||||||||
| "Problems: ", paste0(dups, collapse = "'"), | ||||||||
| call. = FALSE | ||||||||
| ) | ||||||||
| } | ||||||||
| base_rows <- combine_vars(data, params$plot_env, rows, drop = params$drop) | ||||||||
| if (!params$as.table) { | ||||||||
| rev_order <- function(x) factor(x, levels = rev(ulevels(x))) | ||||||||
| base_rows[] <- lapply(base_rows, rev_order) | ||||||||
| } | ||||||||
| base_cols <- combine_vars(data, params$plot_env, cols, drop = params$drop) | ||||||||
| base <- df.grid(base_rows, base_cols) | ||||||||
| # Add margins | ||||||||
| base <- reshape2::add_margins(base, list(names(rows), names(cols)), params$margins) | ||||||||
| # Work around bug in reshape2 | ||||||||
| base <- unique(base) | ||||||||
| # Create panel info dataset | ||||||||
| panel <- plyr::id(base, drop = TRUE) | ||||||||
| panel <- factor(panel, levels = seq_len(attr(panel, "n"))) | ||||||||
| rows <- if (!length(names(rows))) 1L else plyr::id(base[names(rows)], drop = TRUE) | ||||||||
| cols <- if (!length(names(cols))) 1L else plyr::id(base[names(cols)], drop = TRUE) | ||||||||
| panels <- data.frame(PANEL = panel, ROW = rows, COL = cols, base, | ||||||||
| check.names = FALSE, stringsAsFactors = FALSE) | ||||||||
| panels <- panels[order(panels$PANEL), , drop = FALSE] | ||||||||
| rownames(panels) <- NULL | ||||||||
| panels$SCALE_X <- if (params$free$x) panels$COL else 1L | ||||||||
| panels$SCALE_Y <- if (params$free$y) panels$ROW else 1L | ||||||||
| panels | ||||||||
| }, | ||||||||
| map_data = function(data, layout, params) { | ||||||||
| if (empty(data)) { | ||||||||
| return(cbind(data, PANEL = integer(0))) | ||||||||
| } | ||||||||
| rows <- params$rows | ||||||||
| cols <- params$cols | ||||||||
| vars <- c(names(rows), names(cols)) | ||||||||
| # Compute faceting values and add margins | ||||||||
| margin_vars <- list(intersect(names(rows), names(data)), | ||||||||
| intersect(names(cols), names(data))) | ||||||||
| data <- reshape2::add_margins(data, margin_vars, params$margins) | ||||||||
| facet_vals <- eval_facets(c(rows, cols), data, params$plot_env) | ||||||||
| # If any faceting variables are missing, add them in by | ||||||||
| # duplicating the data | ||||||||
| missing_facets <- setdiff(vars, names(facet_vals)) | ||||||||
| if (length(missing_facets) > 0) { | ||||||||
| to_add <- unique(layout[missing_facets]) | ||||||||
| data_rep <- rep.int(1:nrow(data), nrow(to_add)) | ||||||||
| facet_rep <- rep(1:nrow(to_add), each = nrow(data)) | ||||||||
| data <- plyr::unrowname(data[data_rep, , drop = FALSE]) | ||||||||
| facet_vals <- plyr::unrowname(cbind( | ||||||||
| facet_vals[data_rep, , drop = FALSE], | ||||||||
| to_add[facet_rep, , drop = FALSE])) | ||||||||
| } | ||||||||
| # Add PANEL variable | ||||||||
| if (nrow(facet_vals) == 0) { | ||||||||
| # Special case of no faceting | ||||||||
| data$PANEL <- NO_PANEL | ||||||||
| } else { | ||||||||
| facet_vals[] <- lapply(facet_vals[], as.factor) | ||||||||
| facet_vals[] <- lapply(facet_vals[], addNA, ifany = TRUE) | ||||||||
| keys <- plyr::join.keys(facet_vals, layout, by = vars) | ||||||||
| data$PANEL <- layout$PANEL[match(keys$x, keys$y)] | ||||||||
| } | ||||||||
| data | ||||||||
| }, | ||||||||
| draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { | ||||||||
| if ((params$free$x || params$free$y) && !coord$is_free()) { | ||||||||
| stop(snake_class(coord), " doesn't support free scales", call. = FALSE) | ||||||||
| } | ||||||||
| cols <- which(layout$ROW == 1) | ||||||||
| rows <- which(layout$COL == 1) | ||||||||
| axes <- render_axes(ranges[cols], ranges[rows], coord, theme, transpose = TRUE) | ||||||||
| col_vars <- unique(layout[names(params$cols)]) | ||||||||
| row_vars <- unique(layout[names(params$rows)]) | ||||||||
| # Adding labels metadata, useful for labellers | ||||||||
| attr(col_vars, "type") <- "cols" | ||||||||
| attr(col_vars, "facet") <- "grid" | ||||||||
| attr(row_vars, "type") <- "rows" | ||||||||
| attr(row_vars, "facet") <- "grid" | ||||||||
| strips <- render_strips(col_vars, row_vars, params$labeller, theme) | ||||||||
| aspect_ratio <- theme$aspect.ratio | ||||||||
| if (is.null(aspect_ratio) && !params$free$x && !params$free$y) { | ||||||||
| aspect_ratio <- coord$aspect(ranges[[1]]) | ||||||||
| } | ||||||||
| if (is.null(aspect_ratio)) { | ||||||||
| aspect_ratio <- 1 | ||||||||
| respect <- FALSE | ||||||||
| } else { | ||||||||
| respect <- TRUE | ||||||||
| } | ||||||||
| ncol <- max(layout$COL) | ||||||||
| nrow <- max(layout$ROW) | ||||||||
| panel_table <- matrix(panels, nrow = nrow, ncol = ncol, byrow = TRUE) | ||||||||
| # @kohske | ||||||||
| # Now size of each panel is calculated using PANEL$ranges, which is given by | ||||||||
| # coord_train called by train_range. | ||||||||
| # So here, "scale" need not to be referred. | ||||||||
| # | ||||||||
| # In general, panel has all information for building facet. | ||||||||
| if (params$space_free$x) { | ||||||||
| ps <- layout$PANEL[layout$ROW == 1] | ||||||||
| widths <- vapply(ps, function(i) diff(ranges[[i]]$x.range), numeric(1)) | ||||||||
| panel_widths <- unit(widths, "null") | ||||||||
| } else { | ||||||||
| panel_widths <- rep(unit(1, "null"), ncol) | ||||||||
| } | ||||||||
| if (params$space_free$y) { | ||||||||
| ps <- layout$PANEL[layout$COL == 1] | ||||||||
| heights <- vapply(ps, function(i) diff(ranges[[i]]$y.range), numeric(1)) | ||||||||
| panel_heights <- unit(heights, "null") | ||||||||
| } else { | ||||||||
| panel_heights <- rep(unit(1 * aspect_ratio, "null"), nrow) | ||||||||
| } | ||||||||
| panel_table <- gtable_matrix("layout", panel_table, | ||||||||
| panel_widths, panel_heights, respect = respect, clip = coord$clip, z = matrix(1, ncol = ncol, nrow = nrow)) | ||||||||
| panel_table$layout$name <- paste0('panel-', rep(seq_len(ncol), nrow), '-', rep(seq_len(nrow), each = ncol)) | ||||||||
| panel_table <- gtable_add_col_space(panel_table, | ||||||||
| theme$panel.spacing.x %||% theme$panel.spacing) | ||||||||
| panel_table <- gtable_add_row_space(panel_table, | ||||||||
| theme$panel.spacing.y %||% theme$panel.spacing) | ||||||||
| # Add axes | ||||||||
| panel_table <- gtable_add_rows(panel_table, max_height(axes$x$top), 0) | ||||||||
| panel_table <- gtable_add_rows(panel_table, max_height(axes$x$bottom), -1) | ||||||||
| panel_table <- gtable_add_cols(panel_table, max_width(axes$y$left), 0) | ||||||||
| panel_table <- gtable_add_cols(panel_table, max_width(axes$y$right), -1) | ||||||||
| panel_pos_col <- panel_cols(panel_table) | ||||||||
| panel_pos_rows <- panel_rows(panel_table) | ||||||||
| 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) | ||||||||
| 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) | ||||||||
| 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) | ||||||||
| 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) | ||||||||
| # Add strips | ||||||||
| switch_x <- !is.null(params$switch) && params$switch %in% c("both", "x") | ||||||||
| switch_y <- !is.null(params$switch) && params$switch %in% c("both", "y") | ||||||||
| inside_x <- (theme$strip.placement.x %||% theme$strip.placement %||% "inside") == "inside" | ||||||||
| inside_y <- (theme$strip.placement.y %||% theme$strip.placement %||% "inside") == "inside" | ||||||||
| strip_padding <- convertUnit(theme$strip.switch.pad.grid, "cm") | ||||||||
| panel_pos_col <- panel_cols(panel_table) | ||||||||
| if (switch_x) { | ||||||||
| if (!is.null(strips$x$bottom)) { | ||||||||
| if (inside_x) { | ||||||||
| panel_table <- gtable_add_rows(panel_table, max_height(strips$x$bottom), -2) | ||||||||
| 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) | ||||||||
| } else { | ||||||||
| panel_table <- gtable_add_rows(panel_table, strip_padding, -1) | ||||||||
| panel_table <- gtable_add_rows(panel_table, max_height(strips$x$bottom), -1) | ||||||||
| 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) | ||||||||
| } | ||||||||
| } | ||||||||
| } else { | ||||||||
| if (!is.null(strips$x$top)) { | ||||||||
| if (inside_x) { | ||||||||
| panel_table <- gtable_add_rows(panel_table, max_height(strips$x$top), 1) | ||||||||
| 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) | ||||||||
| } else { | ||||||||
| panel_table <- gtable_add_rows(panel_table, strip_padding, 0) | ||||||||
| panel_table <- gtable_add_rows(panel_table, max_height(strips$x$top), 0) | ||||||||
| 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) | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| panel_pos_rows <- panel_rows(panel_table) | ||||||||
| if (switch_y) { | ||||||||
| if (!is.null(strips$y$left)) { | ||||||||
| if (inside_y) { | ||||||||
| panel_table <- gtable_add_cols(panel_table, max_width(strips$y$left), 1) | ||||||||
| 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) | ||||||||
| } else { | ||||||||
| panel_table <- gtable_add_cols(panel_table, strip_padding, 0) | ||||||||
| panel_table <- gtable_add_cols(panel_table, max_width(strips$y$left), 0) | ||||||||
| 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) | ||||||||
| } | ||||||||
| } | ||||||||
| } else { | ||||||||
| if (!is.null(strips$y$right)) { | ||||||||
| if (inside_y) { | ||||||||
| panel_table <- gtable_add_cols(panel_table, max_width(strips$y$right), -2) | ||||||||
| 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) | ||||||||
| } else { | ||||||||
| panel_table <- gtable_add_cols(panel_table, strip_padding, -1) | ||||||||
| panel_table <- gtable_add_cols(panel_table, max_width(strips$y$right), -1) | ||||||||
| 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) | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| panel_table | ||||||||
| }, | ||||||||
| vars = function(self) { | ||||||||
| names(c(self$params$rows, self$params$cols)) | ||||||||
| } | ||||||||
| ) | ||||||||
| # Helpers ----------------------------------------------------------------- | ||||||||
| ulevels <- function(x) { | ||||||||
| if (is.factor(x)) { | ||||||||
| x <- addNA(x, TRUE) | ||||||||
| factor(levels(x), levels(x), exclude = NULL) | ||||||||
| } else { | ||||||||
| sort(unique(x)) | ||||||||
| } | ||||||||
| } | ||||||||
| ggplot2/R/margins.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' @param t,r,b,l Dimensions of each margin. (To remember order, think trouble). | ||||||||
| #' @param unit Default units of dimensions. Defaults to "pt" so it | ||||||||
| #' can be most easily scaled with the text. | ||||||||
| #' @rdname element | ||||||||
| #' @export | ||||||||
| margin <- function(t = 0, r = 0, b = 0, l = 0, unit = "pt") { | ||||||||
| structure(unit(c(t, r, b, l), unit), class = c("margin", "unit")) | ||||||||
| } | ||||||||
| is.margin <- function(x) { | ||||||||
| inherits(x, "margin") | ||||||||
| } | ||||||||
| margin_height <- function(grob, margins) { | ||||||||
| if (is.zero(grob)) return(unit(0, "cm")) | ||||||||
| grobHeight(grob) + margins[1] + margins[3] | ||||||||
| } | ||||||||
| margin_width <- function(grob, margins) { | ||||||||
| if (is.zero(grob)) return(unit(0, "cm")) | ||||||||
| grobWidth(grob) + margins[2] + margins[4] | ||||||||
| } | ||||||||
| #' Text grob, height, and width | ||||||||
| #' | ||||||||
| #' This function returns a list containing a text grob (and, optionally, | ||||||||
| #' debugging grobs) and the height and width of the text grob. | ||||||||
| #' | ||||||||
| #' @param label Either `NULL`, a string (length 1 character vector), or | ||||||||
| #' an expression. | ||||||||
| #' @param x,y x and y locations where the text is to be placed. If `x` and `y` | ||||||||
| #' are `NULL`, `hjust` and `vjust` are used to determine the location. | ||||||||
| #' @inheritParams titleGrob | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| title_spec <- function(label, x, y, hjust, vjust, angle, gp = gpar(), | ||||||||
| debug = FALSE) { | ||||||||
| if (is.null(label)) return(zeroGrob()) | ||||||||
| # We rotate the justifiation values to obtain the correct x and y reference point, | ||||||||
| # since hjust and vjust are applied relative to the rotated text frame in textGrob | ||||||||
| just <- rotate_just(angle, hjust, vjust) | ||||||||
| n <- max(length(x), length(y), 1) | ||||||||
| x <- x %||% unit(rep(just$hjust, n), "npc") | ||||||||
| y <- y %||% unit(rep(just$vjust, n), "npc") | ||||||||
| text_grob <- textGrob( | ||||||||
| label, | ||||||||
| x, | ||||||||
| y, | ||||||||
| hjust = hjust, | ||||||||
| vjust = vjust, | ||||||||
| rot = angle, | ||||||||
| gp = gp | ||||||||
| ) | ||||||||
| # The grob dimensions don't include the text descenders, so these need to be added | ||||||||
| # manually. Because descentDetails calculates the actual descenders of the specific | ||||||||
| # text label, which depends on the label content, we replace the label with one that | ||||||||
| # has the common letters with descenders. This guarantees that the grob always has | ||||||||
| # the same height regardless of whether the text actually contains letters with | ||||||||
| # descenders or not. The same happens automatically with ascenders already. | ||||||||
| descent <- font_descent(gp$fontfamily, gp$fontface, gp$fontsize, gp$cex) | ||||||||
| # Use trigonometry to calculate grobheight and width for rotated grobs. This is only | ||||||||
| # exactly correct when vjust = 1. We need to take the absolute value so we don't make | ||||||||
| # the grob smaller when it's flipped over. | ||||||||
| text_height <- unit(1, "grobheight", text_grob) + abs(cos(angle / 180 * pi)) * descent | ||||||||
| text_width <- unit(1, "grobwidth", text_grob) + abs(sin(angle / 180 * pi)) * descent | ||||||||
| if (isTRUE(debug)) { | ||||||||
| children <- gList( | ||||||||
| rectGrob(gp = gpar(fill = "cornsilk", col = NA)), | ||||||||
| pointsGrob(x, y, pch = 20, gp = gpar(col = "gold")), | ||||||||
| text_grob | ||||||||
| ) | ||||||||
| } else { | ||||||||
| children <- gList(text_grob) | ||||||||
| } | ||||||||
| list( | ||||||||
| text_grob = children, | ||||||||
| text_height = text_height, | ||||||||
| text_width = text_width | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Add margins | ||||||||
| #' | ||||||||
| #' Given a text grob, `add_margins()` adds margins around the grob in the | ||||||||
| #' directions determined by `margin_x` and `margin_y`. | ||||||||
| #' | ||||||||
| #' @param grob Text grob to add margins to. | ||||||||
| #' @param height,width Usually the height and width of the text grob. Passed as | ||||||||
| #' separate arguments from the grob itself because in the special case of | ||||||||
| #' facet strip labels each set of strips should share the same height and | ||||||||
| #' width, even if the labels are of different length. | ||||||||
| #' @inheritParams titleGrob | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| add_margins <- function(grob, height, width, margin = NULL, | ||||||||
| gp = gpar(), margin_x = FALSE, margin_y = FALSE) { | ||||||||
| if (is.null(margin)) { | ||||||||
| margin <- margin(0, 0, 0, 0) | ||||||||
| } | ||||||||
| if (margin_x && margin_y) { | ||||||||
| widths <- unit.c(margin[4], width, margin[2]) | ||||||||
| heights <- unit.c(margin[1], height, margin[3]) | ||||||||
| vp <- viewport( | ||||||||
| layout = grid.layout(3, 3, heights = heights, widths = widths), | ||||||||
| gp = gp | ||||||||
| ) | ||||||||
| child_vp <- viewport(layout.pos.row = 2, layout.pos.col = 2) | ||||||||
| } else if (margin_x) { | ||||||||
| widths <- unit.c(margin[4], width, margin[2]) | ||||||||
| vp <- viewport(layout = grid.layout(1, 3, widths = widths), gp = gp) | ||||||||
| child_vp <- viewport(layout.pos.col = 2) | ||||||||
| heights <- unit(1, "null") | ||||||||
| } else if (margin_y) { | ||||||||
| heights <- unit.c(margin[1], height, margin[3]) | ||||||||
| vp <- viewport(layout = grid.layout(3, 1, heights = heights), gp = gp) | ||||||||
| child_vp <- viewport(layout.pos.row = 2) | ||||||||
| widths <- unit(1, "null") | ||||||||
| } else { | ||||||||
| widths <- width | ||||||||
| heights <- height | ||||||||
| return( | ||||||||
| gTree( | ||||||||
| children = grob, | ||||||||
| widths = widths, | ||||||||
| heights = heights, | ||||||||
| cl = "titleGrob" | ||||||||
| ) | ||||||||
| ) | ||||||||
| } | ||||||||
| gTree( | ||||||||
| children = grob, | ||||||||
| vp = vpTree(vp, vpList(child_vp)), | ||||||||
| widths = widths, | ||||||||
| heights = heights, | ||||||||
| cl = "titleGrob" | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Create a text grob with the proper location and margins | ||||||||
| #' | ||||||||
| #' `titleGrob()` is called when creating titles and labels for axes, legends, | ||||||||
| #' and facet strips. | ||||||||
| #' | ||||||||
| #' @param label Text to place on the plot. These maybe axis titles, axis labels, | ||||||||
| #' facet strip titles, etc. | ||||||||
| #' @param x,y x and y locations where the text is to be placed. | ||||||||
| #' @param hjust,vjust Horizontal and vertical justification of the text. | ||||||||
| #' @param angle Angle of rotation of the text. | ||||||||
| #' @param gp Additional graphical parameters in a call to `gpar()`. | ||||||||
| #' @param margin Margins around the text. See [margin()] for more | ||||||||
| #' details. | ||||||||
| #' @param margin_x,margin_y Whether or not to add margins in the x/y direction. | ||||||||
| #' @param debug If `TRUE`, aids visual debugging by drawing a solid | ||||||||
| #' rectangle behind the complete text area, and a point where each label | ||||||||
| #' is anchored. | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| titleGrob <- function(label, x, y, hjust, vjust, angle = 0, gp = gpar(), | ||||||||
| margin = NULL, margin_x = FALSE, margin_y = FALSE, | ||||||||
| debug = FALSE) { | ||||||||
| if (is.null(label)) | ||||||||
| return(zeroGrob()) | ||||||||
| # Get text grob, text height, and text width | ||||||||
| grob_details <- title_spec( | ||||||||
| label, | ||||||||
| x = x, | ||||||||
| y = y, | ||||||||
| hjust = hjust, | ||||||||
| vjust = vjust, | ||||||||
| angle = angle, | ||||||||
| gp = gp, | ||||||||
| debug = debug | ||||||||
| ) | ||||||||
| add_margins( | ||||||||
| grob = grob_details$text_grob, | ||||||||
| height = grob_details$text_height, | ||||||||
| width = grob_details$text_width, | ||||||||
| gp = gp, | ||||||||
| margin = margin, | ||||||||
| margin_x = margin_x, | ||||||||
| margin_y = margin_y | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| widthDetails.titleGrob <- function(x) { | ||||||||
| sum(x$widths) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| heightDetails.titleGrob <- function(x) { | ||||||||
| sum(x$heights) | ||||||||
| } | ||||||||
| #' Justifies a grob within a larger drawing area | ||||||||
| #' | ||||||||
| #' `justify_grobs()` can be used to take one or more grobs and draw them justified inside a larger | ||||||||
| #' drawing area, such as the cell in a gtable. It is needed to correctly place [`titleGrob`]s | ||||||||
| #' with margins. | ||||||||
| #' | ||||||||
| #' @param grobs The single grob or list of grobs to justify. | ||||||||
| #' @param x,y x and y location of the reference point relative to which justification | ||||||||
| #' should be performed. If `NULL`, justification will be done relative to the | ||||||||
| #' enclosing drawing area (i.e., `x = hjust` and `y = vjust`). | ||||||||
| #' @param hjust,vjust Horizontal and vertical justification of the grob relative to `x` and `y`. | ||||||||
| #' @param int_angle Internal angle of the grob to be justified. When justifying a text | ||||||||
| #' grob with rotated text, this argument can be used to make `hjust` and `vjust` operate | ||||||||
| #' relative to the direction of the text. | ||||||||
| #' @param debug If `TRUE`, aids visual debugging by drawing a solid | ||||||||
| #' rectangle behind the complete grob area. | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| justify_grobs <- function(grobs, x = NULL, y = NULL, hjust = 0.5, vjust = 0.5, | ||||||||
| int_angle = 0, debug = FALSE) { | ||||||||
| if (!inherits(grobs, "grob")) { | ||||||||
| if (is.list(grobs)) { | ||||||||
| return(lapply(grobs, justify_grobs, x, y, hjust, vjust, int_angle, debug)) | ||||||||
| } | ||||||||
| else { | ||||||||
| stop("need individual grob or list of grobs as argument.") | ||||||||
| } | ||||||||
| } | ||||||||
| if (inherits(grobs, "zeroGrob")) { | ||||||||
| return(grobs) | ||||||||
| } | ||||||||
| # adjust hjust and vjust according to internal angle | ||||||||
| just <- rotate_just(int_angle, hjust, vjust) | ||||||||
| x <- x %||% unit(just$hjust, "npc") | ||||||||
| y <- y %||% unit(just$vjust, "npc") | ||||||||
| if (isTRUE(debug)) { | ||||||||
| children <- gList( | ||||||||
| rectGrob(gp = gpar(fill = "lightcyan", col = NA)), | ||||||||
| grobs | ||||||||
| ) | ||||||||
| } | ||||||||
| else { | ||||||||
| children = gList(grobs) | ||||||||
| } | ||||||||
| result_grob <- gTree( | ||||||||
| children = children, | ||||||||
| vp = viewport( | ||||||||
| x = x, | ||||||||
| y = y, | ||||||||
| width = grobWidth(grobs), | ||||||||
| height = grobHeight(grobs), | ||||||||
| just = unlist(just) | ||||||||
| ) | ||||||||
| ) | ||||||||
| if (isTRUE(debug)) { | ||||||||
| #cat("x, y:", c(x, y), "\n") | ||||||||
| #cat("E - hjust, vjust:", c(hjust, vjust), "\n") | ||||||||
| grobTree( | ||||||||
| result_grob, | ||||||||
| pointsGrob(x, y, pch = 20, gp = gpar(col = "mediumturquoise")) | ||||||||
| ) | ||||||||
| } else { | ||||||||
| result_grob | ||||||||
| } | ||||||||
| } | ||||||||
| #' Rotate justification parameters counter-clockwise | ||||||||
| #' | ||||||||
| #' @param angle angle of rotation, in degrees | ||||||||
| #' @param hjust horizontal justification | ||||||||
| #' @param vjust vertical justification | ||||||||
| #' @return A list with two components, `hjust` and `vjust`, containing the rotated hjust and vjust values | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| rotate_just <- function(angle, hjust, vjust) { | ||||||||
| ## Ideally we would like to do something like the following commented-out lines, | ||||||||
| ## but it currently yields unexpected results for angles other than 0, 90, 180, 270. | ||||||||
| ## Problems arise in particular in cases where the horizontal and the vertical | ||||||||
| ## alignment model differ, for example, where horizontal alignment is relative to a | ||||||||
| ## point but vertical alignment is relative to an interval. This case arises for | ||||||||
| ## x and y axis tick labels. | ||||||||
| ## | ||||||||
| ## For more details, see: https://github.com/tidyverse/ggplot2/issues/2653 | ||||||||
| # # convert angle to radians | ||||||||
| #rad <- (angle %||% 0) * pi / 180 | ||||||||
| # | ||||||||
| #hnew <- cos(rad) * hjust - sin(rad) * vjust + (1 - cos(rad) + sin(rad)) / 2 | ||||||||
| #vnew <- sin(rad) * hjust + cos(rad) * vjust + (1 - cos(rad) - sin(rad)) / 2 | ||||||||
| angle <- (angle %||% 0) %% 360 | ||||||||
| if (0 <= angle & angle < 90) { | ||||||||
| hnew <- hjust | ||||||||
| vnew <- vjust | ||||||||
| } else if (90 <= angle & angle < 180) { | ||||||||
| hnew <- 1 - vjust | ||||||||
| vnew <- hjust | ||||||||
| } else if (180 <= angle & angle < 270) { | ||||||||
| hnew <- 1 - hjust | ||||||||
| vnew <- 1 - vjust | ||||||||
| } else if (270 <= angle & angle < 360) { | ||||||||
| hnew <- vjust | ||||||||
| vnew <- 1 - hjust | ||||||||
| } | ||||||||
| list(hjust = hnew, vjust = vnew) | ||||||||
| } | ||||||||
| descent_cache <- new.env(parent = emptyenv()) | ||||||||
| font_descent <- function(family = "", face = "plain", size = 12, cex = 1) { | ||||||||
| key <- paste0(family, ':', face, ":", size, ":", cex) | ||||||||
| descent <- descent_cache[[key]] | ||||||||
| if (is.null(descent)) { | ||||||||
| descent <- descentDetails(textGrob( | ||||||||
| label = "gjpqyQ", | ||||||||
| gp = gpar( | ||||||||
| fontsize = size, | ||||||||
| cex = cex, | ||||||||
| fontfamily = family, | ||||||||
| fontface = face | ||||||||
| ) | ||||||||
| )) | ||||||||
| descent_cache[[key]] <- descent | ||||||||
| } | ||||||||
| descent | ||||||||
| } | ||||||||
| ggplot2/R/guides-axis.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| # Grob for axes | ||||||||
| # | ||||||||
| # @param position of ticks | ||||||||
| # @param labels at ticks | ||||||||
| # @param position of axis (top, bottom, left or right) | ||||||||
| # @param range of data values | ||||||||
| guide_axis <- function(at, labels, position = "right", theme) { | ||||||||
| if (length(at) == 0) | ||||||||
| return(zeroGrob()) | ||||||||
| at <- unit(at, "native") | ||||||||
| position <- match.arg(position, c("top", "bottom", "right", "left")) | ||||||||
| zero <- unit(0, "npc") | ||||||||
| one <- unit(1, "npc") | ||||||||
| label_render <- switch(position, | ||||||||
| top = "axis.text.x.top", bottom = "axis.text.x.bottom", | ||||||||
| left = "axis.text.y.left", right = "axis.text.y.right" | ||||||||
| ) | ||||||||
| label_x <- switch(position, | ||||||||
| top = , | ||||||||
| bottom = at, | ||||||||
| right = theme$axis.ticks.length, | ||||||||
| left = one - theme$axis.ticks.length | ||||||||
| ) | ||||||||
| label_y <- switch(position, | ||||||||
| top = theme$axis.ticks.length, | ||||||||
| bottom = one - theme$axis.ticks.length, | ||||||||
| right = , | ||||||||
| left = at | ||||||||
| ) | ||||||||
| if (is.list(labels)) { | ||||||||
| if (any(sapply(labels, is.language))) { | ||||||||
| labels <- do.call(expression, labels) | ||||||||
| } else { | ||||||||
| labels <- unlist(labels) | ||||||||
| } | ||||||||
| } | ||||||||
| labels <- switch(position, | ||||||||
| top = , | ||||||||
| bottom = element_render(theme, label_render, labels, x = label_x, margin_y = TRUE), | ||||||||
| right = , | ||||||||
| left = element_render(theme, label_render, labels, y = label_y, margin_x = TRUE)) | ||||||||
| line <- switch(position, | ||||||||
| top = element_render(theme, "axis.line.x.top", c(0, 1), c(0, 0), id.lengths = 2), | ||||||||
| bottom = element_render(theme, "axis.line.x.bottom", c(0, 1), c(1, 1), id.lengths = 2), | ||||||||
| right = element_render(theme, "axis.line.y.right", c(0, 0), c(0, 1), id.lengths = 2), | ||||||||
| left = element_render(theme, "axis.line.y.left", c(1, 1), c(0, 1), id.lengths = 2) | ||||||||
| ) | ||||||||
| nticks <- length(at) | ||||||||
| ticks <- switch(position, | ||||||||
| top = element_render(theme, "axis.ticks.x.top", | ||||||||
| x = rep(at, each = 2), | ||||||||
| y = rep(unit.c(zero, theme$axis.ticks.length), nticks), | ||||||||
| id.lengths = rep(2, nticks)), | ||||||||
| bottom = element_render(theme, "axis.ticks.x.bottom", | ||||||||
| x = rep(at, each = 2), | ||||||||
| y = rep(unit.c(one - theme$axis.ticks.length, one), nticks), | ||||||||
| id.lengths = rep(2, nticks)), | ||||||||
| right = element_render(theme, "axis.ticks.y.right", | ||||||||
| x = rep(unit.c(zero, theme$axis.ticks.length), nticks), | ||||||||
| y = rep(at, each = 2), | ||||||||
| id.lengths = rep(2, nticks)), | ||||||||
| left = element_render(theme, "axis.ticks.y.left", | ||||||||
| x = rep(unit.c(one - theme$axis.ticks.length, one), nticks), | ||||||||
| y = rep(at, each = 2), | ||||||||
| id.lengths = rep(2, nticks)) | ||||||||
| ) | ||||||||
| # Create the gtable for the ticks + labels | ||||||||
| gt <- switch(position, | ||||||||
| top = gtable_col("axis", | ||||||||
| grobs = list(labels, ticks), | ||||||||
| width = one, | ||||||||
| heights = unit.c(grobHeight(labels), theme$axis.ticks.length) | ||||||||
| ), | ||||||||
| bottom = gtable_col("axis", | ||||||||
| grobs = list(ticks, labels), | ||||||||
| width = one, | ||||||||
| heights = unit.c(theme$axis.ticks.length, grobHeight(labels)) | ||||||||
| ), | ||||||||
| right = gtable_row("axis", | ||||||||
| grobs = list(ticks, labels), | ||||||||
| widths = unit.c(theme$axis.ticks.length, grobWidth(labels)), | ||||||||
| height = one | ||||||||
| ), | ||||||||
| left = gtable_row("axis", | ||||||||
| grobs = list(labels, ticks), | ||||||||
| widths = unit.c(grobWidth(labels), theme$axis.ticks.length), | ||||||||
| height = one | ||||||||
| ) | ||||||||
| ) | ||||||||
| # Viewport for justifying the axis grob | ||||||||
| justvp <- switch(position, | ||||||||
| top = viewport(y = 0, just = "bottom", height = gtable_height(gt)), | ||||||||
| bottom = viewport(y = 1, just = "top", height = gtable_height(gt)), | ||||||||
| right = viewport(x = 0, just = "left", width = gtable_width(gt)), | ||||||||
| left = viewport(x = 1, just = "right", width = gtable_width(gt)) | ||||||||
| ) | ||||||||
| absoluteGrob( | ||||||||
| gList(line, gt), | ||||||||
| width = gtable_width(gt), | ||||||||
| height = gtable_height(gt), | ||||||||
| vp = justvp | ||||||||
| ) | ||||||||
| } | ||||||||
| ggplot2/R/utilities.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' @export | ||||||||
| #' @examples | ||||||||
| #' ggplot(mpg, aes(displ, hwy)) + | ||||||||
| #' geom_point(alpha = 0.5, colour = "blue") | ||||||||
| #' | ||||||||
| #' ggplot(mpg, aes(displ, hwy)) + | ||||||||
| #' geom_point(colour = alpha("blue", 0.5)) | ||||||||
| scales::alpha | ||||||||
| "%||%" <- function(a, b) { | ||||||||
| if (!is.null(a)) a else b | ||||||||
| } | ||||||||
| "%|W|%" <- function(a, b) { | ||||||||
| if (!is.waive(a)) a else b | ||||||||
| } | ||||||||
| # Check required aesthetics are present | ||||||||
| # This is used by geoms and stats to give a more helpful error message | ||||||||
| # when required aesthetics are missing. | ||||||||
| # | ||||||||
| # @param character vector of required aesthetics | ||||||||
| # @param character vector of present aesthetics | ||||||||
| # @param name of object for error message | ||||||||
| # @keyword internal | ||||||||
| check_required_aesthetics <- function(required, present, name) { | ||||||||
| missing_aes <- setdiff(required, present) | ||||||||
| if (length(missing_aes) == 0) return() | ||||||||
| stop(name, " requires the following missing aesthetics: ", | ||||||||
| paste(missing_aes, collapse = ", "), call. = FALSE) | ||||||||
| } | ||||||||
| # Concatenate a named list for output | ||||||||
| # Print a `list(a=1, b=2)` as `(a=1, b=2)` | ||||||||
| # | ||||||||
| # @param list to concatenate | ||||||||
| # @keyword internal | ||||||||
| #X clist(list(a=1, b=2)) | ||||||||
| #X clist(par()[1:5]) | ||||||||
| clist <- function(l) { | ||||||||
| paste(paste(names(l), l, sep = " = ", collapse = ", "), sep = "") | ||||||||
| } | ||||||||
| try_require <- function(package, fun) { | ||||||||
| if (requireNamespace(package, quietly = TRUE)) { | ||||||||
| library(package, character.only = TRUE) | ||||||||
| return(invisible()) | ||||||||
| } | ||||||||
| stop("Package `", package, "` required for `", fun , "`.\n", | ||||||||
| "Please install and try again.", call. = FALSE) | ||||||||
| } | ||||||||
| # Return unique columns | ||||||||
| # This is used for figuring out which columns are constant within a group | ||||||||
| # | ||||||||
| # @keyword internal | ||||||||
| uniquecols <- function(df) { | ||||||||
| df <- df[1, sapply(df, function(x) length(unique(x)) == 1), drop = FALSE] | ||||||||
| rownames(df) <- 1:nrow(df) | ||||||||
| df | ||||||||
| } | ||||||||
| #' Convenience function to remove missing values from a data.frame | ||||||||
| #' | ||||||||
| #' Remove all non-complete rows, with a warning if `na.rm = FALSE`. | ||||||||
| #' ggplot is somewhat more accommodating of missing values than R generally. | ||||||||
| #' For those stats which require complete data, missing values will be | ||||||||
| #' automatically removed with a warning. If `na.rm = TRUE` is supplied | ||||||||
| #' to the statistic, the warning will be suppressed. | ||||||||
| #' | ||||||||
| #' @param df data.frame | ||||||||
| #' @param na.rm If true, will suppress warning message. | ||||||||
| #' @param vars Character vector of variables to check for missings in | ||||||||
| #' @param name Optional function name to improve error message. | ||||||||
| #' @param finite If `TRUE`, will also remove non-finite values. | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| remove_missing <- function(df, na.rm = FALSE, vars = names(df), name = "", | ||||||||
| finite = FALSE) { | ||||||||
| stopifnot(is.logical(na.rm)) | ||||||||
| vars <- intersect(vars, names(df)) | ||||||||
| if (name != "") name <- paste(" (", name, ")", sep = "") | ||||||||
| if (finite) { | ||||||||
| missing <- !cases(df[, vars, drop = FALSE], is_finite) | ||||||||
| str <- "non-finite" | ||||||||
| } else { | ||||||||
| missing <- !cases(df[, vars, drop = FALSE], is_complete) | ||||||||
| str <- "missing" | ||||||||
| } | ||||||||
| if (any(missing)) { | ||||||||
| df <- df[!missing, ] | ||||||||
| if (!na.rm) { | ||||||||
| warning_wrap( | ||||||||
| "Removed ", sum(missing), " rows containing ", str, " values", name, "." | ||||||||
| ) | ||||||||
| } | ||||||||
| } | ||||||||
| df | ||||||||
| } | ||||||||
| # Returns a logical vector of same length as nrow(x). If all data on a row | ||||||||
| # is finite (not NA, NaN, Inf, or -Inf) return TRUE; otherwise FALSE. | ||||||||
| cases <- function(x, fun) { | ||||||||
| ok <- vapply(x, fun, logical(nrow(x))) | ||||||||
| # Need a special case test when x has exactly one row, because rowSums | ||||||||
| # doesn't respect dimensions for 1x1 matrices. vapply returns a vector (not | ||||||||
| # a matrix when the input has one row. | ||||||||
| if (is.vector(ok)) { | ||||||||
| all(ok) | ||||||||
| } else { | ||||||||
| # Find all the rows where all are TRUE | ||||||||
| rowSums(as.matrix(ok)) == ncol(x) | ||||||||
| } | ||||||||
| } | ||||||||
| # Wrapper around is.finite to handle list cols | ||||||||
| is_finite <- function(x) { | ||||||||
| if (typeof(x) == "list") { | ||||||||
| !vapply(x, is.null, logical(1)) | ||||||||
| } else { | ||||||||
| is.finite(x) | ||||||||
| } | ||||||||
| } | ||||||||
| is_complete <- function(x) { | ||||||||
| if (typeof(x) == "list") { | ||||||||
| !vapply(x, is.null, logical(1)) | ||||||||
| } else { | ||||||||
| !is.na(x) | ||||||||
| } | ||||||||
| } | ||||||||
| #' Used in examples to illustrate when errors should occur. | ||||||||
| #' | ||||||||
| #' @param expr code to evaluate. | ||||||||
| #' @export | ||||||||
| #' @keywords internal | ||||||||
| #' @examples | ||||||||
| #' should_stop(stop("Hi!")) | ||||||||
| #' should_stop(should_stop("Hi!")) | ||||||||
| should_stop <- function(expr) { | ||||||||
| res <- try(print(force(expr)), TRUE) | ||||||||
| if (!inherits(res, "try-error")) stop("No error!", call. = FALSE) | ||||||||
| invisible() | ||||||||
| } | ||||||||
| #' A waiver object. | ||||||||
| #' | ||||||||
| #' A waiver is a "flag" object, similar to `NULL`, that indicates the | ||||||||
| #' calling function should just use the default value. It is used in certain | ||||||||
| #' functions to distinguish between displaying nothing (`NULL`) and | ||||||||
| #' displaying a default value calculated elsewhere (`waiver()`) | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @keywords internal | ||||||||
| waiver <- function() structure(list(), class = "waiver") | ||||||||
| is.waive <- function(x) inherits(x, "waiver") | ||||||||
| rescale01 <- function(x) { | ||||||||
| rng <- range(x, na.rm = TRUE) | ||||||||
| (x - rng[1]) / (rng[2] - rng[1]) | ||||||||
| } | ||||||||
| #' Similar to expand_range(), but taking a vector ‘expand’ | ||||||||
| #' of *four* expansion values, where the 1st and 2nd | ||||||||
| #' elements are used for the lower limit, and the 3rd and | ||||||||
| #' 4th elements are used for the upper limit). | ||||||||
| #' | ||||||||
| #' The ‘expand’ argument can also be of length 2, | ||||||||
| #' and the expansion values for the lower limit | ||||||||
| #' are then reused for the upper limit. | ||||||||
| # | ||||||||
| #' @noRd | ||||||||
| #' @keywords internal | ||||||||
| expand_range4 <- function(limits, expand) { | ||||||||
| stopifnot(is.numeric(expand) && (length(expand) %in% c(2,4))) | ||||||||
| # If only two expansion constants are given (i.e. the old syntax), | ||||||||
| # reuse them to generate a four-element expansion vector | ||||||||
| if (length(expand) == 2) { expand <- c(expand, expand) } | ||||||||
| # Calculate separate range expansion for the lower and | ||||||||
| # upper range limits, and then combine them into one vector | ||||||||
| lower <- expand_range(limits, expand[1], expand[2])[1] | ||||||||
| upper <- expand_range(limits, expand[3], expand[4])[2] | ||||||||
| c(lower, upper) | ||||||||
| } | ||||||||
| #' Generate expansion vector for scales. | ||||||||
| #' | ||||||||
| #' This is a convenience function for generating scale expansion vectors | ||||||||
| #' for the \code{expand} argument of | ||||||||
| #' \code{\link[=scale_x_continuous]{scale_*_continuous}} and | ||||||||
| #' \code{\link[=scale_x_discrete]{scale_*_discrete}}. | ||||||||
| #' The expansions vectors are used to add some space between | ||||||||
| #' the data and the axes. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @param mult vector of multiplicative range expansion factors. | ||||||||
| #' If length 1, both the lower and upper limits of the scale | ||||||||
| #' are expanded outwards by \code{mult}. If length 2, the lower limit | ||||||||
| #' is expanded by \code{mult[1]} and the upper limit by \code{mult[2]}. | ||||||||
| #' @param add vector of additive range expansion constants. | ||||||||
| #' If length 1, both the lower and upper limits of the scale | ||||||||
| #' are expanded outwards by \code{add} units. If length 2, the | ||||||||
| #' lower limit is expanded by \code{add[1]} and the upper | ||||||||
| #' limit by \code{add[2]}. | ||||||||
| #' @examples | ||||||||
| #' # No space below the bars but 10% above them | ||||||||
| #' ggplot(mtcars) + | ||||||||
| #' geom_bar(aes(x = factor(cyl))) + | ||||||||
| #' scale_y_continuous(expand = expand_scale(mult = c(0, .1))) | ||||||||
| #' | ||||||||
| #' # Add 2 units of space on the left and right of the data | ||||||||
| #' ggplot(subset(diamonds, carat > 2), aes(cut, clarity)) + | ||||||||
| #' geom_jitter() + | ||||||||
| #' scale_x_discrete(expand = expand_scale(add = 2)) | ||||||||
| #' | ||||||||
| #' # Reproduce the default range expansion used | ||||||||
| #' # when the ‘expand’ argument is not specified | ||||||||
| #' ggplot(subset(diamonds, carat > 2), aes(cut, price)) + | ||||||||
| #' geom_jitter() + | ||||||||
| #' scale_x_discrete(expand = expand_scale(add = .6)) + | ||||||||
| #' scale_y_continuous(expand = expand_scale(mult = .05)) | ||||||||
| expand_scale = function(mult = 0, add = 0) { | ||||||||
| stopifnot(is.numeric(mult) && is.numeric(add)) | ||||||||
| stopifnot((length(mult) %in% 1:2) && (length(add) %in% 1:2)) | ||||||||
| mult <- rep(mult, length.out = 2) | ||||||||
| add <- rep(add, length.out = 2) | ||||||||
| c(mult[1], add[1], mult[2], add[2]) | ||||||||
| } | ||||||||
| #' Give a deprecation error, warning, or message, depending on version number. | ||||||||
| #' | ||||||||
| #' Version numbers have the format <major>.<minor>.<subminor>, like 0.9.2. | ||||||||
| #' This function compares the current version number of ggplot2 against the | ||||||||
| #' specified `version`, which is the most recent version before the | ||||||||
| #' function (or other object) was deprecated. | ||||||||
| #' | ||||||||
| #' `gg_dep` will give an error, warning, or message, depending on the | ||||||||
| #' difference between the current ggplot2 version and the specified | ||||||||
| #' `version`. | ||||||||
| #' | ||||||||
| #' If the current major number is greater than `version`'s major number, | ||||||||
| #' or if the current minor number is more than 1 greater than `version`'s | ||||||||
| #' minor number, give an error. | ||||||||
| #' | ||||||||
| #' If the current minor number differs from `version`'s minor number by | ||||||||
| #' one, give a warning. | ||||||||
| #' | ||||||||
| #' If the current subminor number differs from `version`'s subminor | ||||||||
| #' number, print a message. | ||||||||
| #' | ||||||||
| #' @param version The last version of ggplot2 where this function was good | ||||||||
| #' (in other words, the last version where it was not deprecated). | ||||||||
| #' @param msg The message to print. | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| gg_dep <- function(version, msg) { | ||||||||
| v <- as.package_version(version) | ||||||||
| cv <- utils::packageVersion("ggplot2") | ||||||||
| # If current major number is greater than last-good major number, or if | ||||||||
| # current minor number is more than 1 greater than last-good minor number, | ||||||||
| # give error. | ||||||||
| if (cv[[1,1]] > v[[1,1]] || cv[[1,2]] > v[[1,2]] + 1) { | ||||||||
| stop(msg, " (Defunct; last used in version ", version, ")", | ||||||||
| call. = FALSE) | ||||||||
| # If minor number differs by one, give warning | ||||||||
| } else if (cv[[1,2]] > v[[1,2]]) { | ||||||||
| warning(msg, " (Deprecated; last used in version ", version, ")", | ||||||||
| call. = FALSE) | ||||||||
| # If only subminor number is greater, give message | ||||||||
| } else if (cv[[1,3]] > v[[1,3]]) { | ||||||||
| message(msg, " (Deprecated; last used in version ", version, ")") | ||||||||
| } | ||||||||
| invisible() | ||||||||
| } | ||||||||
| has_name <- function(x) { | ||||||||
| nms <- names(x) | ||||||||
| if (is.null(nms)) { | ||||||||
| return(rep(FALSE, length(x))) | ||||||||
| } | ||||||||
| !is.na(nms) & nms != "" | ||||||||
| } | ||||||||
| # Convert a snake_case string to camelCase | ||||||||
| camelize <- function(x, first = FALSE) { | ||||||||
| x <- gsub("_(.)", "\\U\\1", x, perl = TRUE) | ||||||||
| if (first) x <- firstUpper(x) | ||||||||
| x | ||||||||
| } | ||||||||
| snakeize <- function(x) { | ||||||||
| x <- gsub("([A-Za-z])([A-Z])([a-z])", "\\1_\\2\\3", x) | ||||||||
| x <- gsub(".", "_", x, fixed = TRUE) | ||||||||
| x <- gsub("([a-z])([A-Z])", "\\1_\\2", x) | ||||||||
| tolower(x) | ||||||||
| } | ||||||||
| firstUpper <- function(s) { | ||||||||
| paste(toupper(substring(s, 1,1)), substring(s, 2), sep = "") | ||||||||
| } | ||||||||
| snake_class <- function(x) { | ||||||||
| snakeize(class(x)[1]) | ||||||||
| } | ||||||||
| empty <- function(df) { | ||||||||
| is.null(df) || nrow(df) == 0 || ncol(df) == 0 | ||||||||
| } | ||||||||
| is.discrete <- function(x) { | ||||||||
| is.factor(x) || is.character(x) || is.logical(x) | ||||||||
| } | ||||||||
| compact <- function(x) { | ||||||||
| null <- vapply(x, is.null, logical(1)) | ||||||||
| x[!null] | ||||||||
| } | ||||||||
| is.formula <- function(x) inherits(x, "formula") | ||||||||
| deparse2 <- function(x) { | ||||||||
| y <- deparse(x, backtick = TRUE) | ||||||||
| if (length(y) == 1) { | ||||||||
| y | ||||||||
| } else { | ||||||||
| paste0(y[[1]], "...") | ||||||||
| } | ||||||||
| } | ||||||||
| message_wrap <- function(...) { | ||||||||
| msg <- paste(..., collapse = "", sep = "") | ||||||||
| wrapped <- strwrap(msg, width = getOption("width") - 2) | ||||||||
| message(paste0(wrapped, collapse = "\n")) | ||||||||
| } | ||||||||
| warning_wrap <- function(...) { | ||||||||
| msg <- paste(..., collapse = "", sep = "") | ||||||||
| wrapped <- strwrap(msg, width = getOption("width") - 2) | ||||||||
| warning(paste0(wrapped, collapse = "\n"), call. = FALSE) | ||||||||
| } | ||||||||
| var_list <- function(x) { | ||||||||
| x <- encodeString(x, quote = "`") | ||||||||
| if (length(x) > 5) { | ||||||||
| x <- c(x[1:5], paste0("and ", length(x) - 5, " more")) | ||||||||
| } | ||||||||
| paste0(x, collapse = ", ") | ||||||||
| } | ||||||||
| dispatch_args <- function(f, ...) { | ||||||||
| args <- list(...) | ||||||||
| formals <- formals(f) | ||||||||
| formals[names(args)] <- args | ||||||||
| formals(f) <- formals | ||||||||
| f | ||||||||
| } | ||||||||
| is_missing_arg <- function(x) identical(x, quote(expr = )) | ||||||||
| # Get all arguments in a function as a list. Will fail if an ellipsis argument | ||||||||
| # named .ignore | ||||||||
| # @param ... passed on in case enclosing function uses ellipsis in argument list | ||||||||
| find_args <- function(...) { | ||||||||
| env <- parent.frame() | ||||||||
| args <- names(formals(sys.function(sys.parent(1)))) | ||||||||
| vals <- mget(args, envir = env) | ||||||||
| vals <- vals[!vapply(vals, is_missing_arg, logical(1))] | ||||||||
| modify_list(vals, list(..., `...` = NULL)) | ||||||||
| } | ||||||||
| # Used in annotations to ensure printed even when no | ||||||||
| # global data | ||||||||
| dummy_data <- function() new_data_frame(x = NA) | ||||||||
| with_seed_null <- function(seed, code) { | ||||||||
| if (is.null(seed)) { | ||||||||
| code | ||||||||
| } else { | ||||||||
| withr::with_seed(seed, code) | ||||||||
| } | ||||||||
| } | ||||||||
| seq_asc <- function(to, from) { | ||||||||
| if (to > from) { | ||||||||
| integer() | ||||||||
| } else { | ||||||||
| to:from | ||||||||
| } | ||||||||
| } | ||||||||
| # Needed to trigger package loading | ||||||||
| #' @importFrom tibble tibble | ||||||||
| NULL | ||||||||
| # Check inputs with tibble but allow column vectors (see #2609 and #2374) | ||||||||
| as_gg_data_frame <- function(x) { | ||||||||
| x <- lapply(x, validate_column_vec) | ||||||||
| as.data.frame(tibble::as_tibble(x)) | ||||||||
| } | ||||||||
| validate_column_vec <- function(x) { | ||||||||
| if (is_column_vec(x)) { | ||||||||
| dim(x) <- NULL | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| is_column_vec <- function(x) { | ||||||||
| dims <- dim(x) | ||||||||
| length(dims) == 2L && dims[[2]] == 1L | ||||||||
| } | ||||||||
| # Parse takes a vector of n lines and returns m expressions. | ||||||||
| # See https://github.com/tidyverse/ggplot2/issues/2864 for discussion. | ||||||||
| # | ||||||||
| # parse(text = c("alpha", "", "gamma")) | ||||||||
| # #> expression(alpha, gamma) | ||||||||
| # | ||||||||
| # parse_safe(text = c("alpha", "", "gamma")) | ||||||||
| # #> expression(alpha, NA, gamma) | ||||||||
| # | ||||||||
| parse_safe <- function(text) { | ||||||||
| stopifnot(is.character(text)) | ||||||||
| out <- vector("expression", length(text)) | ||||||||
| for (i in seq_along(text)) { | ||||||||
| expr <- parse(text = text[[i]]) | ||||||||
| out[[i]] <- if (length(expr) == 0) NA else expr[[1]] | ||||||||
| } | ||||||||
| out | ||||||||
| } | ||||||||
| ggplot2/R/labeller.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Useful labeller functions | ||||||||
| #' | ||||||||
| #' Labeller functions are in charge of formatting the strip labels of | ||||||||
| #' facet grids and wraps. Most of them accept a `multi_line` | ||||||||
| #' argument to control whether multiple factors (defined in formulae | ||||||||
| #' such as `~first + second`) should be displayed on a single | ||||||||
| #' line separated with commas, or each on their own line. | ||||||||
| #' | ||||||||
| #' `label_value()` only displays the value of a factor while | ||||||||
| #' `label_both()` displays both the variable name and the factor | ||||||||
| #' value. `label_context()` is context-dependent and uses | ||||||||
| #' `label_value()` for single factor faceting and | ||||||||
| #' `label_both()` when multiple factors are | ||||||||
| #' involved. `label_wrap_gen()` uses [base::strwrap()] | ||||||||
| #' for line wrapping. | ||||||||
| #' | ||||||||
| #' `label_parsed()` interprets the labels as plotmath | ||||||||
| #' expressions. [label_bquote()] offers a more flexible | ||||||||
| #' way of constructing plotmath expressions. See examples and | ||||||||
| #' [bquote()] for details on the syntax of the | ||||||||
| #' argument. | ||||||||
| #' | ||||||||
| #' @section Writing New Labeller Functions: | ||||||||
| #' | ||||||||
| #' Note that an easy way to write a labeller function is to | ||||||||
| #' transform a function operating on character vectors with | ||||||||
| #' [as_labeller()]. | ||||||||
| #' | ||||||||
| #' A labeller function accepts a data frame of labels (character | ||||||||
| #' vectors) containing one column for each factor. Multiple factors | ||||||||
| #' occur with formula of the type `~first + second`. | ||||||||
| #' | ||||||||
| #' The return value must be a rectangular list where each 'row' | ||||||||
| #' characterises a single facet. The list elements can be either | ||||||||
| #' character vectors or lists of plotmath expressions. When multiple | ||||||||
| #' elements are returned, they get displayed on their own new lines | ||||||||
| #' (i.e., each facet gets a multi-line strip of labels). | ||||||||
| #' | ||||||||
| #' To illustrate, let's say your labeller returns a list of two | ||||||||
| #' character vectors of length 3. This is a rectangular list because | ||||||||
| #' all elements have the same length. The first facet will get the | ||||||||
| #' first elements of each vector and display each of them on their | ||||||||
| #' own line. Then the second facet gets the second elements of each | ||||||||
| #' vector, and so on. | ||||||||
| #' | ||||||||
| #' If it's useful to your labeller, you can retrieve the `type` | ||||||||
| #' attribute of the incoming data frame of labels. The value of this | ||||||||
| #' attribute reflects the kind of strips your labeller is dealing | ||||||||
| #' with: `"cols"` for columns and `"rows"` for rows. Note | ||||||||
| #' that [facet_wrap()] has columns by default and rows | ||||||||
| #' when the strips are switched with the `switch` option. The | ||||||||
| #' `facet` attribute also provides metadata on the labels. It | ||||||||
| #' takes the values `"grid"` or `"wrap"`. | ||||||||
| #' | ||||||||
| #' For compatibility with [labeller()], each labeller | ||||||||
| #' function must have the `labeller` S3 class. | ||||||||
| #' | ||||||||
| #' @param labels Data frame of labels. Usually contains only one | ||||||||
| #' element, but faceting over multiple factors entails multiple | ||||||||
| #' label variables. | ||||||||
| #' @param multi_line Whether to display the labels of multiple factors | ||||||||
| #' on separate lines. | ||||||||
| #' @param sep String separating variables and values. | ||||||||
| #' @param width Maximum number of characters before wrapping the strip. | ||||||||
| #' @family facet | ||||||||
| #' @seealso [labeller()], [as_labeller()], | ||||||||
| #' [label_bquote()] | ||||||||
| #' @examples | ||||||||
| #' mtcars$cyl2 <- factor(mtcars$cyl, labels = c("alpha", "beta", "gamma")) | ||||||||
| #' p <- ggplot(mtcars, aes(wt, mpg)) + geom_point() | ||||||||
| #' | ||||||||
| #' # The default is label_value | ||||||||
| #' p + facet_grid(. ~ cyl, labeller = label_value) | ||||||||
| #' | ||||||||
| #' \donttest{ | ||||||||
| #' # Displaying both the values and the variables | ||||||||
| #' p + facet_grid(. ~ cyl, labeller = label_both) | ||||||||
| #' | ||||||||
| #' # Displaying only the values or both the values and variables | ||||||||
| #' # depending on whether multiple factors are facetted over | ||||||||
| #' p + facet_grid(am ~ vs+cyl, labeller = label_context) | ||||||||
| #' | ||||||||
| #' # Interpreting the labels as plotmath expressions | ||||||||
| #' p + facet_grid(. ~ cyl2) | ||||||||
| #' p + facet_grid(. ~ cyl2, labeller = label_parsed) | ||||||||
| #' } | ||||||||
| #' @name labellers | ||||||||
| NULL | ||||||||
| collapse_labels_lines <- function(labels) { | ||||||||
| out <- do.call("Map", c(list(paste, sep = ", "), labels)) | ||||||||
| list(unname(unlist(out))) | ||||||||
| } | ||||||||
| #' @rdname labellers | ||||||||
| #' @export | ||||||||
| label_value <- function(labels, multi_line = TRUE) { | ||||||||
| labels <- lapply(labels, as.character) | ||||||||
| if (multi_line) { | ||||||||
| labels | ||||||||
| } else { | ||||||||
| collapse_labels_lines(labels) | ||||||||
| } | ||||||||
| } | ||||||||
| # Should ideally not have the 'function' class here, but this is | ||||||||
| # currently needed for Roxygen | ||||||||
| class(label_value) <- c("function", "labeller") | ||||||||
| # Helper for label_both | ||||||||
| label_variable <- function(labels, multi_line = TRUE) { | ||||||||
| if (multi_line) { | ||||||||
| row <- as.list(names(labels)) | ||||||||
| } else { | ||||||||
| row <- list(paste(names(labels), collapse = ", ")) | ||||||||
| } | ||||||||
| lapply(row, rep, nrow(labels) %||% length(labels[[1]])) | ||||||||
| } | ||||||||
| #' @rdname labellers | ||||||||
| #' @export | ||||||||
| label_both <- function(labels, multi_line = TRUE, sep = ": ") { | ||||||||
| value <- label_value(labels, multi_line = multi_line) | ||||||||
| variable <- label_variable(labels, multi_line = multi_line) | ||||||||
| if (multi_line) { | ||||||||
| out <- vector("list", length(value)) | ||||||||
| for (i in seq_along(out)) { | ||||||||
| out[[i]] <- paste(variable[[i]], value[[i]], sep = sep) | ||||||||
| } | ||||||||
| } else { | ||||||||
| value <- do.call("paste", c(value, sep = ", ")) | ||||||||
| variable <- do.call("paste", c(variable, sep = ", ")) | ||||||||
| out <- Map(paste, variable, value, sep = sep) | ||||||||
| out <- list(unname(unlist(out))) | ||||||||
| } | ||||||||
| out | ||||||||
| } | ||||||||
| class(label_both) <- c("function", "labeller") | ||||||||
| #' @rdname labellers | ||||||||
| #' @export | ||||||||
| label_context <- function(labels, multi_line = TRUE, sep = ": ") { | ||||||||
| if (length(labels) == 1) { | ||||||||
| label_value(labels, multi_line) | ||||||||
| } else { | ||||||||
| label_both(labels, multi_line) | ||||||||
| } | ||||||||
| } | ||||||||
| class(label_context) <- c("function", "labeller") | ||||||||
| #' @rdname labellers | ||||||||
| #' @export | ||||||||
| label_parsed <- function(labels, multi_line = TRUE) { | ||||||||
| labels <- label_value(labels, multi_line = multi_line) | ||||||||
| if (multi_line) { | ||||||||
| # Using unname() and c() to return a cleaner and easily testable | ||||||||
| # object structure | ||||||||
| lapply(unname(labels), lapply, function(values) { | ||||||||
| c(parse(text = as.character(values))) | ||||||||
| }) | ||||||||
| } else { | ||||||||
| lapply(labels, function(values) { | ||||||||
| values <- paste0("list(", values, ")") | ||||||||
| lapply(values, function(expr) c(parse(text = expr))) | ||||||||
| }) | ||||||||
| } | ||||||||
| } | ||||||||
| class(label_parsed) <- c("function", "labeller") | ||||||||
| find_names <- function(expr) { | ||||||||
| if (is.call(expr)) { | ||||||||
| unlist(lapply(expr[-1], find_names)) | ||||||||
| } else if (is.name(expr)) { | ||||||||
| as.character(expr) | ||||||||
| } | ||||||||
| } | ||||||||
| #' Label with mathematical expressions | ||||||||
| #' | ||||||||
| #' `label_bquote()` offers a flexible way of labelling | ||||||||
| #' facet rows or columns with plotmath expressions. Backquoted | ||||||||
| #' variables will be replaced with their value in the facet. | ||||||||
| #' | ||||||||
| #' @param rows Backquoted labelling expression for rows. | ||||||||
| #' @param cols Backquoted labelling expression for columns. | ||||||||
| #' @param default Unused, kept for compatibility. | ||||||||
| #' @seealso \link{labellers}, [labeller()], | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # The variables mentioned in the plotmath expression must be | ||||||||
| #' # backquoted and referred to by their names. | ||||||||
| #' p <- ggplot(mtcars, aes(wt, mpg)) + geom_point() | ||||||||
| #' p + facet_grid(vs ~ ., labeller = label_bquote(alpha ^ .(vs))) | ||||||||
| #' p + facet_grid(. ~ vs, labeller = label_bquote(cols = .(vs) ^ .(vs))) | ||||||||
| #' p + facet_grid(. ~ vs + am, labeller = label_bquote(cols = .(am) ^ .(vs))) | ||||||||
| label_bquote <- function(rows = NULL, cols = NULL, | ||||||||
| default) { | ||||||||
| cols_quoted <- substitute(cols) | ||||||||
| rows_quoted <- substitute(rows) | ||||||||
| has_warned <- FALSE | ||||||||
| fun <- function(labels) { | ||||||||
| quoted <- resolve_labeller(rows_quoted, cols_quoted, labels) | ||||||||
| if (is.null(quoted)) { | ||||||||
| return(label_value(labels)) | ||||||||
| } | ||||||||
| evaluate <- function(...) { | ||||||||
| params <- list(...) | ||||||||
| # Mapping `x` to the first variable for backward-compatibility, | ||||||||
| # but only if there is no facetted variable also named `x` | ||||||||
| if ("x" %in% find_names(quoted) && !"x" %in% names(params)) { | ||||||||
| if (!has_warned) { | ||||||||
| warning("Referring to `x` is deprecated, use variable name instead", | ||||||||
| call. = FALSE) | ||||||||
| # The function is called for each facet so this avoids | ||||||||
| # multiple warnings | ||||||||
| has_warned <<- TRUE | ||||||||
| } | ||||||||
| params$x <- params[[1]] | ||||||||
| } | ||||||||
| eval(substitute(bquote(expr, params), list(expr = quoted))) | ||||||||
| } | ||||||||
| list(do.call("Map", c(list(f = evaluate), labels))) | ||||||||
| } | ||||||||
| structure(fun, class = "labeller") | ||||||||
| } | ||||||||
| utils::globalVariables(c("x", ".")) | ||||||||
| #' @rdname labellers | ||||||||
| #' @export | ||||||||
| label_wrap_gen <- function(width = 25, multi_line = TRUE) { | ||||||||
| fun <- function(labels) { | ||||||||
| labels <- label_value(labels, multi_line = multi_line) | ||||||||
| lapply(labels, function(x) { | ||||||||
| x <- strwrap(x, width = width, simplify = FALSE) | ||||||||
| vapply(x, paste, character(1), collapse = "\n") | ||||||||
| }) | ||||||||
| } | ||||||||
| structure(fun, class = "labeller") | ||||||||
| } | ||||||||
| is_labeller <- function(x) inherits(x, "labeller") | ||||||||
| resolve_labeller <- function(rows, cols, labels) { | ||||||||
| if (is.null(cols) && is.null(rows)) { | ||||||||
| stop("Supply one of rows or cols", call. = FALSE) | ||||||||
| } | ||||||||
| if (attr(labels, "facet") == "wrap") { | ||||||||
| # Return either rows or cols for facet_wrap() | ||||||||
| if (!is.null(cols) && !is.null(rows)) { | ||||||||
| stop("Cannot supply both rows and cols to facet_wrap()", call. = FALSE) | ||||||||
| } | ||||||||
| cols %||% rows | ||||||||
| } else { | ||||||||
| if (attr(labels, "type") == "rows") { | ||||||||
| rows | ||||||||
| } else { | ||||||||
| cols | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| #' Coerce to labeller function | ||||||||
| #' | ||||||||
| #' This transforms objects to labeller functions. Used internally by | ||||||||
| #' [labeller()]. | ||||||||
| #' @param x Object to coerce to a labeller function. If a named | ||||||||
| #' character vector, it is used as a lookup table before being | ||||||||
| #' passed on to `default`. If a non-labeller function, it is | ||||||||
| #' assumed it takes and returns character vectors and is applied to | ||||||||
| #' the labels. If a labeller, it is simply applied to the labels. | ||||||||
| #' @param multi_line Whether to display the labels of multiple factors | ||||||||
| #' on separate lines. This is passed to the labeller function. | ||||||||
| #' @param default Default labeller to process the labels produced by | ||||||||
| #' lookup tables or modified by non-labeller functions. | ||||||||
| #' @seealso [labeller()], \link{labellers} | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' p <- ggplot(mtcars, aes(disp, drat)) + geom_point() | ||||||||
| #' p + facet_wrap(~am) | ||||||||
| #' | ||||||||
| #' # Rename labels on the fly with a lookup character vector | ||||||||
| #' to_string <- as_labeller(c(`0` = "Zero", `1` = "One")) | ||||||||
| #' p + facet_wrap(~am, labeller = to_string) | ||||||||
| #' | ||||||||
| #' # Quickly transform a function operating on character vectors to a | ||||||||
| #' # labeller function: | ||||||||
| #' appender <- function(string, suffix = "-foo") paste0(string, suffix) | ||||||||
| #' p + facet_wrap(~am, labeller = as_labeller(appender)) | ||||||||
| #' | ||||||||
| #' # If you have more than one faceting variable, be sure to dispatch | ||||||||
| #' # your labeller to the right variable with labeller() | ||||||||
| #' p + facet_grid(cyl ~ am, labeller = labeller(am = to_string)) | ||||||||
| as_labeller <- function(x, default = label_value, multi_line = TRUE) { | ||||||||
| force(x) | ||||||||
| fun <- function(labels) { | ||||||||
| labels <- lapply(labels, as.character) | ||||||||
| # Dispatch multi_line argument to the labeller function instead of | ||||||||
| # supplying it to the labeller call because some labellers do not | ||||||||
| # support it. | ||||||||
| default <- dispatch_args(default, multi_line = multi_line) | ||||||||
| if (is_labeller(x)) { | ||||||||
| x <- dispatch_args(x, multi_line = multi_line) | ||||||||
| x(labels) | ||||||||
| } else if (is.function(x)) { | ||||||||
| default(lapply(labels, x)) | ||||||||
| } else if (is.character(x)) { | ||||||||
| default(lapply(labels, function(label) x[label])) | ||||||||
| } else { | ||||||||
| default(labels) | ||||||||
| } | ||||||||
| } | ||||||||
| structure(fun, class = "labeller") | ||||||||
| } | ||||||||
| #' Construct labelling specification | ||||||||
| #' | ||||||||
| #' This function makes it easy to assign different labellers to | ||||||||
| #' different factors. The labeller can be a function or it can be a | ||||||||
| #' named character vectors that will serve as a lookup table. | ||||||||
| #' | ||||||||
| #' In case of functions, if the labeller has class `labeller`, it | ||||||||
| #' is directly applied on the data frame of labels. Otherwise, it is | ||||||||
| #' applied to the columns of the data frame of labels. The data frame | ||||||||
| #' is then processed with the function specified in the | ||||||||
| #' `.default` argument. This is intended to be used with | ||||||||
| #' functions taking a character vector such as | ||||||||
| #' [Hmisc::capitalize()]. | ||||||||
| #' | ||||||||
| #' @param ... Named arguments of the form \code{variable = | ||||||||
| #' labeller}. Each labeller is passed to [as_labeller()] | ||||||||
| #' and can be a lookup table, a function taking and returning | ||||||||
| #' character vectors, or simply a labeller function. | ||||||||
| #' @param .rows,.cols Labeller for a whole margin (either the rows or | ||||||||
| #' the columns). It is passed to [as_labeller()]. When a | ||||||||
| #' margin-wide labeller is set, make sure you don't mention in | ||||||||
| #' `...` any variable belonging to the margin. | ||||||||
| #' @param keep.as.numeric Deprecated. All supplied labellers and | ||||||||
| #' on-labeller functions should be able to work with character | ||||||||
| #' labels. | ||||||||
| #' @param .multi_line Whether to display the labels of multiple | ||||||||
| #' factors on separate lines. This is passed to the labeller | ||||||||
| #' function. | ||||||||
| #' @param .default Default labeller for variables not specified. Also | ||||||||
| #' used with lookup tables or non-labeller functions. | ||||||||
| #' @family facet labeller | ||||||||
| #' @seealso [as_labeller()], \link{labellers} | ||||||||
| #' @return A labeller function to supply to [facet_grid()] | ||||||||
| #' for the argument `labeller`. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' \donttest{ | ||||||||
| #' p1 <- ggplot(mtcars, aes(x = mpg, y = wt)) + geom_point() | ||||||||
| #' | ||||||||
| #' # You can assign different labellers to variables: | ||||||||
| #' p1 + facet_grid( | ||||||||
| #' vs + am ~ gear, | ||||||||
| #' labeller = labeller(vs = label_both, am = label_value) | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' # Or whole margins: | ||||||||
| #' p1 + facet_grid( | ||||||||
| #' vs + am ~ gear, | ||||||||
| #' labeller = labeller(.rows = label_both, .cols = label_value) | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' # You can supply functions operating on strings: | ||||||||
| #' capitalize <- function(string) { | ||||||||
| #' substr(string, 1, 1) <- toupper(substr(string, 1, 1)) | ||||||||
| #' string | ||||||||
| #' } | ||||||||
| #' p2 <- ggplot(msleep, aes(x = sleep_total, y = awake)) + geom_point() | ||||||||
| #' p2 + facet_grid(vore ~ conservation, labeller = labeller(vore = capitalize)) | ||||||||
| #' | ||||||||
| #' # Or use character vectors as lookup tables: | ||||||||
| #' conservation_status <- c( | ||||||||
| #' cd = "Conservation Dependent", | ||||||||
| #' en = "Endangered", | ||||||||
| #' lc = "Least concern", | ||||||||
| #' nt = "Near Threatened", | ||||||||
| #' vu = "Vulnerable", | ||||||||
| #' domesticated = "Domesticated" | ||||||||
| #' ) | ||||||||
| #' ## Source: http://en.wikipedia.org/wiki/Wikipedia:Conservation_status | ||||||||
| #' | ||||||||
| #' p2 + facet_grid(vore ~ conservation, labeller = labeller( | ||||||||
| #' .default = capitalize, | ||||||||
| #' conservation = conservation_status | ||||||||
| #' )) | ||||||||
| #' | ||||||||
| #' # In the following example, we rename the levels to the long form, | ||||||||
| #' # then apply a wrap labeller to the columns to prevent cropped text | ||||||||
| #' msleep$conservation2 <- plyr::revalue(msleep$conservation, | ||||||||
| #' conservation_status) | ||||||||
| #' p3 <- ggplot(msleep, aes(x = sleep_total, y = awake)) + geom_point() | ||||||||
| #' p3 + | ||||||||
| #' facet_grid(vore ~ conservation2, | ||||||||
| #' labeller = labeller(conservation2 = label_wrap_gen(10)) | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' # labeller() is especially useful to act as a global labeller. You | ||||||||
| #' # can set it up once and use it on a range of different plots with | ||||||||
| #' # different facet specifications. | ||||||||
| #' | ||||||||
| #' global_labeller <- labeller( | ||||||||
| #' vore = capitalize, | ||||||||
| #' conservation = conservation_status, | ||||||||
| #' conservation2 = label_wrap_gen(10), | ||||||||
| #' .default = label_both | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' p2 + facet_grid(vore ~ conservation, labeller = global_labeller) | ||||||||
| #' p3 + facet_wrap(~conservation2, labeller = global_labeller) | ||||||||
| #' } | ||||||||
| labeller <- function(..., .rows = NULL, .cols = NULL, | ||||||||
| keep.as.numeric = NULL, .multi_line = TRUE, | ||||||||
| .default = label_value) { | ||||||||
| if (!is.null(keep.as.numeric)) { | ||||||||
| .Deprecated(old = "keep.as.numeric") | ||||||||
| } | ||||||||
| dots <- list(...) | ||||||||
| .default <- as_labeller(.default) | ||||||||
| function(labels) { | ||||||||
| if (!is.null(.rows) || !is.null(.cols)) { | ||||||||
| margin_labeller <- resolve_labeller(.rows, .cols, labels) | ||||||||
| } else { | ||||||||
| margin_labeller <- NULL | ||||||||
| } | ||||||||
| if (is.null(margin_labeller)) { | ||||||||
| labellers <- lapply(dots, as_labeller) | ||||||||
| } else { | ||||||||
| margin_labeller <- as_labeller(margin_labeller, default = .default, | ||||||||
| multi_line = .multi_line) | ||||||||
| # Check that variable-specific labellers do not overlap with | ||||||||
| # margin-wide labeller | ||||||||
| if (any(names(dots) %in% names(labels))) { | ||||||||
| stop("Conflict between .", attr(labels, "type"), " and ", | ||||||||
| paste(names(dots), collapse = ", "), call. = FALSE) | ||||||||
| } | ||||||||
| } | ||||||||
| # Apply relevant labeller | ||||||||
| if (is.null(margin_labeller)) { | ||||||||
| # Apply named labeller one by one | ||||||||
| out <- lapply(names(labels), function(label) { | ||||||||
| if (label %in% names(labellers)) { | ||||||||
| labellers[[label]](labels[label])[[1]] | ||||||||
| } else { | ||||||||
| .default(labels[label])[[1]] | ||||||||
| } | ||||||||
| }) | ||||||||
| names(out) <- names(labels) | ||||||||
| if (.multi_line) { | ||||||||
| out | ||||||||
| } else { | ||||||||
| collapse_labels_lines(out) | ||||||||
| } | ||||||||
| } else { | ||||||||
| margin_labeller(labels) | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| #' Build facet strips | ||||||||
| #' | ||||||||
| #' Builds a set of facet strips from a data frame of labels. | ||||||||
| #' | ||||||||
| #' @param label_df Data frame of labels to place in strips. | ||||||||
| #' @param labeller Labelling function. | ||||||||
| #' @param theme A theme object. | ||||||||
| #' @param horizontal Whether the strips are horizontal (e.g. x facets) or not. | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| build_strip <- function(label_df, labeller, theme, horizontal) { | ||||||||
| labeller <- match.fun(labeller) | ||||||||
| # No labelling data, so return empty row/col | ||||||||
| if (empty(label_df)) { | ||||||||
| return(if (horizontal) { | ||||||||
| list(top = NULL, bottom = NULL) | ||||||||
| } else { | ||||||||
| list(left = NULL, right = NULL) | ||||||||
| }) | ||||||||
| } | ||||||||
| text_theme <- if (horizontal) "strip.text.x" else "strip.text.y" | ||||||||
| element <- calc_element(text_theme, theme) | ||||||||
| if (inherits(element, "element_blank")) { | ||||||||
| grobs <- rep(list(zeroGrob()), nrow(label_df)) | ||||||||
| return(structure( | ||||||||
| list(grobs, grobs), | ||||||||
| names = if (horizontal) c('top', 'bottom') else c('left', 'right') | ||||||||
| )) | ||||||||
| } | ||||||||
| # Create matrix of labels | ||||||||
| labels <- lapply(labeller(label_df), cbind) | ||||||||
| labels <- do.call("cbind", labels) | ||||||||
| gp <- gpar( | ||||||||
| fontsize = element$size, | ||||||||
| col = element$colour, | ||||||||
| fontfamily = element$family, | ||||||||
| fontface = element$face, | ||||||||
| lineheight = element$lineheight | ||||||||
| ) | ||||||||
| if (horizontal) { | ||||||||
| grobs <- create_strip_labels(labels, element, gp) | ||||||||
| grobs <- ggstrip(grobs, theme, element, gp, horizontal, clip = "on") | ||||||||
| list( | ||||||||
| top = grobs, | ||||||||
| bottom = grobs | ||||||||
| ) | ||||||||
| } else { | ||||||||
| grobs <- create_strip_labels(labels, element, gp) | ||||||||
| grobs_right <- grobs[, rev(seq_len(ncol(grobs))), drop = FALSE] | ||||||||
| grobs_right <- ggstrip( | ||||||||
| grobs_right, | ||||||||
| theme, | ||||||||
| element, | ||||||||
| gp, | ||||||||
| horizontal, | ||||||||
| clip = "on" | ||||||||
| ) | ||||||||
| # Change angle of strip labels for y strips that are placed on the left side | ||||||||
| if (inherits(element, "element_text")) { | ||||||||
| element$angle <- adjust_angle(element$angle) | ||||||||
| } | ||||||||
| grobs_left <- create_strip_labels(labels, element, gp) | ||||||||
| grobs_left <- ggstrip( | ||||||||
| grobs_left, | ||||||||
| theme, | ||||||||
| element, | ||||||||
| gp, | ||||||||
| horizontal, | ||||||||
| clip = "off" | ||||||||
| ) | ||||||||
| list( | ||||||||
| left = grobs_left, | ||||||||
| right = grobs_right | ||||||||
| ) | ||||||||
| } | ||||||||
| } | ||||||||
| #' Create list of strip labels | ||||||||
| #' | ||||||||
| #' Calls [title_spec()] on all the labels for a set of strips to create a list | ||||||||
| #' of text grobs, heights, and widths. | ||||||||
| #' | ||||||||
| #' @param labels Matrix of strip labels | ||||||||
| #' @param element Theme element (see [calc_element()]). | ||||||||
| #' @param gp Additional graphical parameters. | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| create_strip_labels <- function(labels, element, gp) { | ||||||||
| grobs <- lapply(labels, title_spec, | ||||||||
| x = NULL, | ||||||||
| y = NULL, | ||||||||
| hjust = element$hjust, | ||||||||
| vjust = element$vjust, | ||||||||
| angle = element$angle, | ||||||||
| gp = gp, | ||||||||
| debug = element$debug | ||||||||
| ) | ||||||||
| dim(grobs) <- dim(labels) | ||||||||
| grobs | ||||||||
| } | ||||||||
| #' Grob for strip labels | ||||||||
| #' | ||||||||
| #' Takes the output from title_spec, adds margins, creates gList with strip | ||||||||
| #' background and label, and returns gtable matrix. | ||||||||
| #' | ||||||||
| #' @param grobs Output from [title_spec()]. | ||||||||
| #' @param theme Theme object. | ||||||||
| #' @param element Theme element (see [calc_element()]). | ||||||||
| #' @param gp Additional graphical parameters. | ||||||||
| #' @param horizontal Whether the strips are horizontal (e.g. x facets) or not. | ||||||||
| #' @param clip should drawing be clipped to the specified cells (‘"on"’),the | ||||||||
| #' entire table (‘"inherit"’), or not at all (‘"off"’). | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| ggstrip <- function(grobs, theme, element, gp, horizontal = TRUE, clip) { | ||||||||
| if (horizontal) { | ||||||||
| height <- max_height(lapply(grobs, function(x) x$text_height)) | ||||||||
| width <- unit(1, "null") | ||||||||
| } else { | ||||||||
| height <- unit(1, "null") | ||||||||
| width <- max_width(lapply(grobs, function(x) x$text_width)) | ||||||||
| } | ||||||||
| # Add margins around text grob | ||||||||
| grobs <- apply( | ||||||||
| grobs, | ||||||||
| c(1, 2), | ||||||||
| function(x) { | ||||||||
| add_margins( | ||||||||
| grob = x[[1]]$text_grob, | ||||||||
| height = height, | ||||||||
| width = width, | ||||||||
| gp = gp, | ||||||||
| margin = element$margin, | ||||||||
| margin_x = TRUE, | ||||||||
| margin_y = TRUE | ||||||||
| ) | ||||||||
| } | ||||||||
| ) | ||||||||
| background <- if (horizontal) "strip.background.x" else "strip.background.y" | ||||||||
| # Put text on a strip | ||||||||
| grobs <- apply( | ||||||||
| grobs, | ||||||||
| c(1, 2), | ||||||||
| function(label) { | ||||||||
| ggname( | ||||||||
| "strip", | ||||||||
| gTree( | ||||||||
| children = gList( | ||||||||
| element_render(theme, background), | ||||||||
| label[[1]] | ||||||||
| ) | ||||||||
| ) | ||||||||
| ) | ||||||||
| }) | ||||||||
| if (horizontal) { | ||||||||
| height <- height + sum(element$margin[c(1, 3)]) | ||||||||
| } else { | ||||||||
| width <- width + sum(element$margin[c(2, 4)]) | ||||||||
| } | ||||||||
| apply( | ||||||||
| grobs, | ||||||||
| 1, | ||||||||
| function(x) { | ||||||||
| if (horizontal) { | ||||||||
| mat <- matrix(x, ncol = 1) | ||||||||
| } else { | ||||||||
| mat <- matrix(x, nrow = 1) | ||||||||
| } | ||||||||
| gtable_matrix( | ||||||||
| "strip", | ||||||||
| mat, | ||||||||
| rep(width, ncol(mat)), | ||||||||
| rep(height, nrow(mat)), | ||||||||
| clip = clip | ||||||||
| ) | ||||||||
| }) | ||||||||
| } | ||||||||
| # Helper to adjust angle of switched strips | ||||||||
| adjust_angle <- function(angle) { | ||||||||
| if (is.null(angle)) { | ||||||||
| -90 | ||||||||
| } else if ((angle + 180) > 360) { | ||||||||
| angle - 180 | ||||||||
| } else { | ||||||||
| angle + 180 | ||||||||
| } | ||||||||
| } | ||||||||
| # Check for old school labeller | ||||||||
| check_labeller <- function(labeller) { | ||||||||
| labeller <- match.fun(labeller) | ||||||||
| is_deprecated <- all(c("variable", "value") %in% names(formals(labeller))) | ||||||||
| if (is_deprecated) { | ||||||||
| old_labeller <- labeller | ||||||||
| labeller <- function(labels) { | ||||||||
| Map(old_labeller, names(labels), labels) | ||||||||
| } | ||||||||
| warning("The labeller API has been updated. Labellers taking `variable`", | ||||||||
| "and `value` arguments are now deprecated. See labellers documentation.", | ||||||||
| call. = FALSE) | ||||||||
| } | ||||||||
| labeller | ||||||||
| } | ||||||||
| gtable/R/grid.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Visualise the layout of a gtable. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @param x a gtable object | ||||||||
| gtable_show_layout <- function(x) { | ||||||||
| if (!is.gtable(x)) stop("x must be a gtable", call. = FALSE) | ||||||||
| grid.show.layout(gtable_layout(x)) | ||||||||
| } | ||||||||
| gtable_layout <- function(x) { | ||||||||
| if (!is.gtable(x)) stop("x must be a gtable", call. = FALSE) | ||||||||
| grid.layout( | ||||||||
| nrow = length(x$heights), heights = x$heights, | ||||||||
| ncol = length(x$widths), widths = x$widths, | ||||||||
| respect = x$respect | ||||||||
| ) | ||||||||
| } | ||||||||
| vpname <- function(row) { | ||||||||
| row <- unclass(row) | ||||||||
| paste(row$name, ".", row$t, "-", row$r, "-", row$b, "-", row$l, sep = "") | ||||||||
| } | ||||||||
| #' @export | ||||||||
| widthDetails.gtable <- function(x) absolute.size(gtable_width(x)) | ||||||||
| #' @export | ||||||||
| heightDetails.gtable <- function(x) absolute.size(gtable_height(x)) | ||||||||
| #' @export | ||||||||
| makeContext.gtable <- function(x) { | ||||||||
| layoutvp <- viewport(layout = gtable_layout(x), name = x$name) | ||||||||
| if (is.null(x$vp)) { | ||||||||
| x$vp <- layoutvp | ||||||||
| } else { | ||||||||
| x$vp <- vpStack(x$vp, layoutvp) | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| #' @export | ||||||||
| makeContent.gtable <- function(x) { | ||||||||
| children_vps <- mapply(child_vp, | ||||||||
| vp_name = vpname(x$layout), | ||||||||
| t = .subset2(x$layout, "t"), r = .subset2(x$layout, "r"), | ||||||||
| b = .subset2(x$layout, "b"), l = .subset2(x$layout, "l"), | ||||||||
| clip = x$layout$clip, | ||||||||
| SIMPLIFY = FALSE | ||||||||
| ) | ||||||||
| x$grobs <- mapply(wrap_gtableChild, x$grobs, children_vps, | ||||||||
| SIMPLIFY = FALSE | ||||||||
| ) | ||||||||
| setChildren(x, do.call("gList", x$grobs[order(.subset2(x$layout, "z"))])) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| makeContext.gTableChild <- function(x) { | ||||||||
| if (is.null(x$vp)) { | ||||||||
| x$vp <- x$wrapvp | ||||||||
| } else { | ||||||||
| x$vp <- vpStack(x$wrapvp, x$vp) | ||||||||
| } | ||||||||
| # A gTableChild extends an arbitrary grob class | ||||||||
| # so allow existing makeContext() behaviour of | ||||||||
| # original grob class to still occur | ||||||||
| NextMethod() | ||||||||
| } | ||||||||
| # Return the viewport for a child grob in a gtable | ||||||||
| child_vp <- function(vp_name, t, r, b, l, clip) { | ||||||||
| viewport( | ||||||||
| name = vp_name, layout.pos.row = t:b, | ||||||||
| layout.pos.col = l:r, clip = clip | ||||||||
| ) | ||||||||
| } | ||||||||
| # Turn a grob into a gtableChild, and store information about the | ||||||||
| # viewport used within the gtable | ||||||||
| wrap_gtableChild <- function(grob, vp) { | ||||||||
| grob$wrapvp <- vp | ||||||||
| grob$name <- vp$name | ||||||||
| class(grob) <- c("gTableChild", class(grob)) | ||||||||
| grob | ||||||||
| } | ||||||||
| gtable/R/add-rows-cols.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Add new rows in specified position. | ||||||||
| #' | ||||||||
| #' @param x a [gtable()] object | ||||||||
| #' @param heights a unit vector giving the heights of the new rows | ||||||||
| #' @param pos new row will be added below this position. Defaults to | ||||||||
| #' adding row on bottom. `0` adds on the top. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' library(grid) | ||||||||
| #' rect <- rectGrob(gp = gpar(fill = "#00000080")) | ||||||||
| #' tab <- gtable(unit(rep(1, 3), "null"), unit(rep(1, 3), "null")) | ||||||||
| #' tab <- gtable_add_grob(tab, rect, t = 1, l = 1, r = 3) | ||||||||
| #' tab <- gtable_add_grob(tab, rect, t = 1, b = 3, l = 1) | ||||||||
| #' tab <- gtable_add_grob(tab, rect, t = 1, b = 3, l = 3) | ||||||||
| #' dim(tab) | ||||||||
| #' plot(tab) | ||||||||
| #' | ||||||||
| #' # Grobs will continue to span over new rows if added in the middle | ||||||||
| #' tab2 <- gtable_add_rows(tab, unit(1, "null"), 1) | ||||||||
| #' dim(tab2) | ||||||||
| #' plot(tab2) | ||||||||
| #' | ||||||||
| #' # But not when added to top (0) or bottom (-1, the default) | ||||||||
| #' tab3 <- gtable_add_rows(tab, unit(1, "null")) | ||||||||
| #' tab3 <- gtable_add_rows(tab3, unit(1, "null"), 0) | ||||||||
| #' dim(tab3) | ||||||||
| #' plot(tab3) | ||||||||
| gtable_add_rows <- function(x, heights, pos = -1) { | ||||||||
| if (!is.gtable(x)) stop("x must be a gtable", call. = FALSE) | ||||||||
| if (length(pos) != 1) stop("pos must be a scalar unit", call. = FALSE) | ||||||||
| n <- length(heights) | ||||||||
| pos <- neg_to_pos(pos, length(x$heights)) | ||||||||
| # Shift existing rows down | ||||||||
| x$heights <- insert.unit(x$heights, heights, pos) | ||||||||
| layout <- unclass(x$layout) | ||||||||
| layout$t <- ifelse(layout$t > pos, layout$t + n, layout$t) | ||||||||
| layout$b <- ifelse(layout$b > pos, layout$b + n, layout$b) | ||||||||
| x$layout <- new_data_frame(layout) | ||||||||
| x | ||||||||
| } | ||||||||
| #' Add new columns in specified position. | ||||||||
| #' | ||||||||
| #' @param x a [gtable()] object | ||||||||
| #' @param widths a unit vector giving the widths of the new columns | ||||||||
| #' @param pos new row will be added below this position. Defaults to | ||||||||
| #' adding col on right. `0` adds on the left. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' library(grid) | ||||||||
| #' rect <- rectGrob(gp = gpar(fill = "#00000080")) | ||||||||
| #' tab <- gtable(unit(rep(1, 3), "null"), unit(rep(1, 3), "null")) | ||||||||
| #' tab <- gtable_add_grob(tab, rect, t = 1, l = 1, r = 3) | ||||||||
| #' tab <- gtable_add_grob(tab, rect, t = 1, b = 3, l = 1) | ||||||||
| #' tab <- gtable_add_grob(tab, rect, t = 1, b = 3, l = 3) | ||||||||
| #' dim(tab) | ||||||||
| #' plot(tab) | ||||||||
| #' | ||||||||
| #' # Grobs will continue to span over new rows if added in the middle | ||||||||
| #' tab2 <- gtable_add_cols(tab, unit(1, "null"), 1) | ||||||||
| #' dim(tab2) | ||||||||
| #' plot(tab2) | ||||||||
| #' | ||||||||
| #' # But not when added to left (0) or right (-1, the default) | ||||||||
| #' tab3 <- gtable_add_cols(tab, unit(1, "null")) | ||||||||
| #' tab3 <- gtable_add_cols(tab3, unit(1, "null"), 0) | ||||||||
| #' dim(tab3) | ||||||||
| #' plot(tab3) | ||||||||
| gtable_add_cols <- function(x, widths, pos = -1) { | ||||||||
| if (!is.gtable(x)) stop("x must be a gtable", call. = FALSE) | ||||||||
| if (length(pos) != 1) stop("pos must be a scalar unit", call. = FALSE) | ||||||||
| n <- length(widths) | ||||||||
| pos <- neg_to_pos(pos, length(x$widths)) | ||||||||
| # Shift existing columns right | ||||||||
| x$widths <- insert.unit(x$widths, widths, pos) | ||||||||
| layout <- unclass(x$layout) | ||||||||
| layout$l <- ifelse(layout$l > pos, layout$l + n, layout$l) | ||||||||
| layout$r <- ifelse(layout$r > pos, layout$r + n, layout$r) | ||||||||
| x$layout <- new_data_frame(layout) | ||||||||
| x | ||||||||
| } | ||||||||
| ggplot2/R/theme.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Modify components of a theme | ||||||||
| #' | ||||||||
| #' Themes are a powerful way to customize the non-data components of your | ||||||||
| #' plots: i.e. titles, labels, fonts, background, gridlines, and legends. | ||||||||
| #' Themes can be used to give plots a consistent customized look. | ||||||||
| #' Modify a single plot's theme using `theme()`; see [theme_update()] if | ||||||||
| #' you want modify the active theme, to affect all subsequent plots. Theme | ||||||||
| #' elements are documented together according to inheritance, read more | ||||||||
| #' about theme inheritance below. | ||||||||
| #' | ||||||||
| #' @section Theme inheritance: | ||||||||
| #' Theme elements inherit properties from other theme elements heirarchically. | ||||||||
| #' For example, `axis.title.x.bottom` inherits from `axis.title.x` which inherits | ||||||||
| #' from `axis.title`, which in turn inherits from `text`. All text elements inherit | ||||||||
| #' directly or indirectly from `text`; all lines inherit from | ||||||||
| #' `line`, and all rectangular objects inherit from `rect`. | ||||||||
| #' This means that you can modify the appearance of multiple elements by | ||||||||
| #' setting a single high-level component. | ||||||||
| #' | ||||||||
| #' Learn more about setting these aesthetics in `vignette("ggplot2-specs")`. | ||||||||
| #' | ||||||||
| #' @param line all line elements ([element_line()]) | ||||||||
| #' @param rect all rectangular elements ([element_rect()]) | ||||||||
| #' @param text all text elements ([element_text()]) | ||||||||
| #' @param title all title elements: plot, axes, legends ([element_text()]; | ||||||||
| #' inherits from `text`) | ||||||||
| #' @param aspect.ratio aspect ratio of the panel | ||||||||
| #' | ||||||||
| #' @param axis.title,axis.title.x,axis.title.y,axis.title.x.top,axis.title.x.bottom,axis.title.y.left,axis.title.y.right | ||||||||
| #' labels of axes ([element_text()]). Specify all axes' labels (`axis.title`), | ||||||||
| #' labels by plane (using `axis.title.x` or `axis.title.y`), or individually | ||||||||
| #' for each axis (using `axis.title.x.bottom`, `axis.title.x.top`, | ||||||||
| #' `axis.title.y.left`, `axis.title.y.right`). `axis.title.*.*` inherits from | ||||||||
| #' `axis.title.*` which inherits from `axis.title`, which in turn inherits | ||||||||
| #' from `text` | ||||||||
| #' @param axis.text,axis.text.x,axis.text.y,axis.text.x.top,axis.text.x.bottom,axis.text.y.left,axis.text.y.right | ||||||||
| #' tick labels along axes ([element_text()]). Specify all axis tick labels (`axis.text`), | ||||||||
| #' tick labels by plane (using `axis.text.x` or `axis.text.y`), or individually | ||||||||
| #' for each axis (using `axis.text.x.bottom`, `axis.text.x.top`, | ||||||||
| #' `axis.text.y.left`, `axis.text.y.right`). `axis.text.*.*` inherits from | ||||||||
| #' `axis.text.*` which inherits from `axis.text`, which in turn inherits | ||||||||
| #' from `text` | ||||||||
| #' @param axis.ticks,axis.ticks.x,axis.ticks.x.top,axis.ticks.x.bottom,axis.ticks.y,axis.ticks.y.left,axis.ticks.y.right | ||||||||
| #' tick marks along axes ([element_line()]). Specify all tick marks (`axis.ticks`), | ||||||||
| #' ticks by plane (using `axis.ticks.x` or `axis.ticks.y`), or individually | ||||||||
| #' for each axis (using `axis.ticks.x.bottom`, `axis.ticks.x.top`, | ||||||||
| #' `axis.ticks.y.left`, `axis.ticks.y.right`). `axis.ticks.*.*` inherits from | ||||||||
| #' `axis.ticks.*` which inherits from `axis.ticks`, which in turn inherits | ||||||||
| #' from `line` | ||||||||
| #' @param axis.ticks.length length of tick marks (`unit`) | ||||||||
| #' @param axis.line,axis.line.x,axis.line.x.top,axis.line.x.bottom,axis.line.y,axis.line.y.left,axis.line.y.right | ||||||||
| #' lines along axes ([element_line()]). Specify lines along all axes (`axis.line`), | ||||||||
| #' lines for each plane (using `axis.line.x` or `axis.line.y`), or individually | ||||||||
| #' for each axis (using `axis.line.x.bottom`, `axis.line.x.top`, | ||||||||
| #' `axis.line.y.left`, `axis.line.y.right`). `axis.line.*.*` inherits from | ||||||||
| #' `axis.line.*` which inherits from `axis.line`, which in turn inherits | ||||||||
| #' from `line` | ||||||||
| #' | ||||||||
| #' @param legend.background background of legend ([element_rect()]; inherits | ||||||||
| #' from `rect`) | ||||||||
| #' @param legend.margin the margin around each legend ([margin()]) | ||||||||
| #' @param legend.spacing,legend.spacing.x,legend.spacing.y | ||||||||
| #' the spacing between legends (`unit`). `legend.spacing.x` & `legend.spacing.y` | ||||||||
| #' inherit from `legend.spacing` or can be specified separately | ||||||||
| #' @param legend.key background underneath legend keys ([element_rect()]; | ||||||||
| #' inherits from `rect`) | ||||||||
| #' @param legend.key.size,legend.key.height,legend.key.width | ||||||||
| #' size of legend keys (`unit`); key background height & width inherit from | ||||||||
| #' `legend.key.size` or can be specified separately | ||||||||
| #' @param legend.text legend item labels ([element_text()]; inherits from | ||||||||
| #' `text`) | ||||||||
| #' @param legend.text.align alignment of legend labels (number from 0 (left) to | ||||||||
| #' 1 (right)) | ||||||||
| #' @param legend.title title of legend ([element_text()]; inherits from | ||||||||
| #' `title`) | ||||||||
| #' @param legend.title.align alignment of legend title (number from 0 (left) to | ||||||||
| #' 1 (right)) | ||||||||
| #' @param legend.position the position of legends ("none", "left", "right", | ||||||||
| #' "bottom", "top", or two-element numeric vector) | ||||||||
| #' @param legend.direction layout of items in legends ("horizontal" or | ||||||||
| #' "vertical") | ||||||||
| #' @param legend.justification anchor point for positioning legend inside plot | ||||||||
| #' ("center" or two-element numeric vector) or the justification according to | ||||||||
| #' the plot area when positioned outside the plot | ||||||||
| #' @param legend.box arrangement of multiple legends ("horizontal" or | ||||||||
| #' "vertical") | ||||||||
| #' @param legend.box.just justification of each legend within the overall | ||||||||
| #' bounding box, when there are multiple legends ("top", "bottom", "left", or | ||||||||
| #' "right") | ||||||||
| #' @param legend.box.margin margins around the full legend area, as specified | ||||||||
| #' using [margin()] | ||||||||
| #' @param legend.box.background background of legend area ([element_rect()]; | ||||||||
| #' inherits from `rect`) | ||||||||
| #' @param legend.box.spacing The spacing between the plotting area and the | ||||||||
| #' legend box (`unit`) | ||||||||
| #' | ||||||||
| #' @param panel.background background of plotting area, drawn underneath plot | ||||||||
| #' ([element_rect()]; inherits from `rect`) | ||||||||
| #' @param panel.border border around plotting area, drawn on top of plot so that | ||||||||
| #' it covers tick marks and grid lines. This should be used with | ||||||||
| #' `fill = NA` | ||||||||
| #' ([element_rect()]; inherits from `rect`) | ||||||||
| #' @param panel.spacing,panel.spacing.x,panel.spacing.y spacing between facet | ||||||||
| #' panels (`unit`). `panel.spacing.x` & `panel.spacing.y` inherit from `panel.spacing` | ||||||||
| #' or can be specified separately. | ||||||||
| #' @param panel.grid,panel.grid.major,panel.grid.minor,panel.grid.major.x,panel.grid.major.y,panel.grid.minor.x,panel.grid.minor.y | ||||||||
| #' grid lines ([element_line()]). Specify major grid lines, | ||||||||
| #' or minor grid lines separately (using `panel.grid.major` or `panel.grid.minor`) | ||||||||
| #' or individually for each axis (using `panel.grid.major.x`, `panel.grid.minor.x`, | ||||||||
| #' `panel.grid.major.y`, `panel.grid.minor.y`). Y axis grid lines are horizontal | ||||||||
| #' and x axis grid lines are vertical. `panel.grid.*.*` inherits from | ||||||||
| #' `panel.grid.*` which inherits from `panel.grid`, which in turn inherits | ||||||||
| #' from `line` | ||||||||
| #' @param panel.ontop option to place the panel (background, gridlines) over | ||||||||
| #' the data layers (`logical`). Usually used with a transparent or blank | ||||||||
| #' `panel.background`. | ||||||||
| #' | ||||||||
| #' @param plot.background background of the entire plot ([element_rect()]; | ||||||||
| #' inherits from `rect`) | ||||||||
| #' @param plot.title plot title (text appearance) ([element_text()]; inherits | ||||||||
| #' from `title`) left-aligned by default | ||||||||
| #' @param plot.subtitle plot subtitle (text appearance) ([element_text()]; | ||||||||
| #' inherits from `title`) left-aligned by default | ||||||||
| #' @param plot.caption caption below the plot (text appearance) | ||||||||
| #' ([element_text()]; inherits from `title`) right-aligned by default | ||||||||
| #' @param plot.tag upper-left label to identify a plot (text appearance) | ||||||||
| #' ([element_text()]; inherits from `title`) left-aligned by default | ||||||||
| #' @param plot.tag.position The position of the tag as a string ("topleft", | ||||||||
| #' "top", "topright", "left", "right", "bottomleft", "bottom", "bottomright) | ||||||||
| #' or a coordinate. If a string, extra space will be added to accommodate the | ||||||||
| #' tag. | ||||||||
| #' @param plot.margin margin around entire plot (`unit` with the sizes of | ||||||||
| #' the top, right, bottom, and left margins) | ||||||||
| #' | ||||||||
| #' @param strip.background,strip.background.x,strip.background.y | ||||||||
| #' background of facet labels ([element_rect()]; | ||||||||
| #' inherits from `rect`). Horizontal facet background (`strip.background.x`) | ||||||||
| #' & vertical facet background (`strip.background.y`) inherit from | ||||||||
| #' `strip.background` or can be specified separately | ||||||||
| #' @param strip.placement placement of strip with respect to axes, | ||||||||
| #' either "inside" or "outside". Only important when axes and strips are | ||||||||
| #' on the same side of the plot. | ||||||||
| #' @param strip.text,strip.text.x,strip.text.y facet labels ([element_text()]; | ||||||||
| #' inherits from `text`). Horizontal facet labels (`strip.text.x`) & vertical | ||||||||
| #' facet labels (`strip.text.y`) inherit from `strip.text` or can be specified | ||||||||
| #' separately | ||||||||
| #' @param strip.switch.pad.grid space between strips and axes when strips are | ||||||||
| #' switched (`unit`) | ||||||||
| #' @param strip.switch.pad.wrap space between strips and axes when strips are | ||||||||
| #' switched (`unit`) | ||||||||
| #' | ||||||||
| #' @param ... additional element specifications not part of base ggplot2. If | ||||||||
| #' supplied `validate` needs to be set to `FALSE`. | ||||||||
| #' @param complete set this to `TRUE` if this is a complete theme, such as | ||||||||
| #' the one returned by [theme_grey()]. Complete themes behave | ||||||||
| #' differently when added to a ggplot object. Also, when setting | ||||||||
| #' `complete = TRUE` all elements will be set to inherit from blank | ||||||||
| #' elements. | ||||||||
| #' @param validate `TRUE` to run `validate_element()`, `FALSE` to bypass checks. | ||||||||
| #' | ||||||||
| #' @seealso | ||||||||
| #' [+.gg()] and \code{\link{\%+replace\%}}, | ||||||||
| #' [element_blank()], [element_line()], | ||||||||
| #' [element_rect()], and [element_text()] for | ||||||||
| #' details of the specific theme elements. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' p1 <- ggplot(mtcars, aes(wt, mpg)) + | ||||||||
| #' geom_point() + | ||||||||
| #' labs(title = "Fuel economy declines as weight increases") | ||||||||
| #' p1 | ||||||||
| #' | ||||||||
| #' # Plot --------------------------------------------------------------------- | ||||||||
| #' p1 + theme(plot.title = element_text(size = rel(2))) | ||||||||
| #' p1 + theme(plot.background = element_rect(fill = "green")) | ||||||||
| #' | ||||||||
| #' # Panels -------------------------------------------------------------------- | ||||||||
| #' | ||||||||
| #' p1 + theme(panel.background = element_rect(fill = "white", colour = "grey50")) | ||||||||
| #' p1 + theme(panel.border = element_rect(linetype = "dashed", fill = NA)) | ||||||||
| #' p1 + theme(panel.grid.major = element_line(colour = "black")) | ||||||||
| #' p1 + theme( | ||||||||
| #' panel.grid.major.y = element_blank(), | ||||||||
| #' panel.grid.minor.y = element_blank() | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' # Put gridlines on top of data | ||||||||
| #' p1 + theme( | ||||||||
| #' panel.background = element_rect(fill = NA), | ||||||||
| #' panel.grid.major = element_line(colour = "grey50"), | ||||||||
| #' panel.ontop = TRUE | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' # Axes ---------------------------------------------------------------------- | ||||||||
| #' p1 + theme(axis.line = element_line(size = 3, colour = "grey80")) | ||||||||
| #' p1 + theme(axis.text = element_text(colour = "blue")) | ||||||||
| #' p1 + theme(axis.ticks = element_line(size = 2)) | ||||||||
| #' p1 + theme(axis.ticks.length = unit(.25, "cm")) | ||||||||
| #' p1 + theme(axis.title.y = element_text(size = rel(1.5), angle = 90)) | ||||||||
| #' | ||||||||
| #' \donttest{ | ||||||||
| #' # Legend -------------------------------------------------------------------- | ||||||||
| #' p2 <- ggplot(mtcars, aes(wt, mpg)) + | ||||||||
| #' geom_point(aes(colour = factor(cyl), shape = factor(vs))) + | ||||||||
| #' labs( | ||||||||
| #' x = "Weight (1000 lbs)", | ||||||||
| #' y = "Fuel economy (mpg)", | ||||||||
| #' colour = "Cylinders", | ||||||||
| #' shape = "Transmission" | ||||||||
| #' ) | ||||||||
| #' p2 | ||||||||
| #' | ||||||||
| #' # Position | ||||||||
| #' p2 + theme(legend.position = "none") | ||||||||
| #' p2 + theme(legend.justification = "top") | ||||||||
| #' p2 + theme(legend.position = "bottom") | ||||||||
| #' | ||||||||
| #' # Or place legends inside the plot using relative coordinates between 0 and 1 | ||||||||
| #' # legend.justification sets the corner that the position refers to | ||||||||
| #' p2 + theme( | ||||||||
| #' legend.position = c(.95, .95), | ||||||||
| #' legend.justification = c("right", "top"), | ||||||||
| #' legend.box.just = "right", | ||||||||
| #' legend.margin = margin(6, 6, 6, 6) | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' # The legend.box properties work similarly for the space around | ||||||||
| #' # all the legends | ||||||||
| #' p2 + theme( | ||||||||
| #' legend.box.background = element_rect(), | ||||||||
| #' legend.box.margin = margin(6, 6, 6, 6) | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' # You can also control the display of the keys | ||||||||
| #' # and the justification related to the plot area can be set | ||||||||
| #' p2 + theme(legend.key = element_rect(fill = "white", colour = "black")) | ||||||||
| #' p2 + theme(legend.text = element_text(size = 8, colour = "red")) | ||||||||
| #' p2 + theme(legend.title = element_text(face = "bold")) | ||||||||
| #' | ||||||||
| #' # Strips -------------------------------------------------------------------- | ||||||||
| #' | ||||||||
| #' p3 <- ggplot(mtcars, aes(wt, mpg)) + | ||||||||
| #' geom_point() + | ||||||||
| #' facet_wrap(~ cyl) | ||||||||
| #' p3 | ||||||||
| #' | ||||||||
| #' p3 + theme(strip.background = element_rect(colour = "black", fill = "white")) | ||||||||
| #' p3 + theme(strip.text.x = element_text(colour = "white", face = "bold")) | ||||||||
| #' p3 + theme(panel.spacing = unit(1, "lines")) | ||||||||
| #' } | ||||||||
| theme <- function(line, | ||||||||
| rect, | ||||||||
| text, | ||||||||
| title, | ||||||||
| aspect.ratio, | ||||||||
| axis.title, | ||||||||
| axis.title.x, | ||||||||
| axis.title.x.top, | ||||||||
| axis.title.x.bottom, | ||||||||
| axis.title.y, | ||||||||
| axis.title.y.left, | ||||||||
| axis.title.y.right, | ||||||||
| axis.text, | ||||||||
| axis.text.x, | ||||||||
| axis.text.x.top, | ||||||||
| axis.text.x.bottom, | ||||||||
| axis.text.y, | ||||||||
| axis.text.y.left, | ||||||||
| axis.text.y.right, | ||||||||
| axis.ticks, | ||||||||
| axis.ticks.x, | ||||||||
| axis.ticks.x.top, | ||||||||
| axis.ticks.x.bottom, | ||||||||
| axis.ticks.y, | ||||||||
| axis.ticks.y.left, | ||||||||
| axis.ticks.y.right, | ||||||||
| axis.ticks.length, | ||||||||
| axis.line, | ||||||||
| axis.line.x, | ||||||||
| axis.line.x.top, | ||||||||
| axis.line.x.bottom, | ||||||||
| axis.line.y, | ||||||||
| axis.line.y.left, | ||||||||
| axis.line.y.right, | ||||||||
| legend.background, | ||||||||
| legend.margin, | ||||||||
| legend.spacing, | ||||||||
| legend.spacing.x, | ||||||||
| legend.spacing.y, | ||||||||
| legend.key, | ||||||||
| legend.key.size, | ||||||||
| legend.key.height, | ||||||||
| legend.key.width, | ||||||||
| legend.text, | ||||||||
| legend.text.align, | ||||||||
| legend.title, | ||||||||
| legend.title.align, | ||||||||
| legend.position, | ||||||||
| legend.direction, | ||||||||
| legend.justification, | ||||||||
| legend.box, | ||||||||
| legend.box.just, | ||||||||
| legend.box.margin, | ||||||||
| legend.box.background, | ||||||||
| legend.box.spacing, | ||||||||
| panel.background, | ||||||||
| panel.border, | ||||||||
| panel.spacing, | ||||||||
| panel.spacing.x, | ||||||||
| panel.spacing.y, | ||||||||
| panel.grid, | ||||||||
| panel.grid.major, | ||||||||
| panel.grid.minor, | ||||||||
| panel.grid.major.x, | ||||||||
| panel.grid.major.y, | ||||||||
| panel.grid.minor.x, | ||||||||
| panel.grid.minor.y, | ||||||||
| panel.ontop, | ||||||||
| plot.background, | ||||||||
| plot.title, | ||||||||
| plot.subtitle, | ||||||||
| plot.caption, | ||||||||
| plot.tag, | ||||||||
| plot.tag.position, | ||||||||
| plot.margin, | ||||||||
| strip.background, | ||||||||
| strip.background.x, | ||||||||
| strip.background.y, | ||||||||
| strip.placement, | ||||||||
| strip.text, | ||||||||
| strip.text.x, | ||||||||
| strip.text.y, | ||||||||
| strip.switch.pad.grid, | ||||||||
| strip.switch.pad.wrap, | ||||||||
| ..., | ||||||||
| complete = FALSE, | ||||||||
| validate = TRUE | ||||||||
| ) { | ||||||||
| elements <- find_args(..., complete = NULL, validate = NULL) | ||||||||
| if (!is.null(elements$axis.ticks.margin)) { | ||||||||
| warning("`axis.ticks.margin` is deprecated. Please set `margin` property ", | ||||||||
| " of `axis.text` instead", call. = FALSE) | ||||||||
| elements$axis.ticks.margin <- NULL | ||||||||
| } | ||||||||
| if (!is.null(elements$panel.margin)) { | ||||||||
| warning("`panel.margin` is deprecated. Please use `panel.spacing` property ", | ||||||||
| "instead", call. = FALSE) | ||||||||
| elements$panel.spacing <- elements$panel.margin | ||||||||
| elements$panel.margin <- NULL | ||||||||
| } | ||||||||
| if (!is.null(elements$panel.margin.x)) { | ||||||||
| warning("`panel.margin.x` is deprecated. Please use `panel.spacing.x` property ", | ||||||||
| "instead", call. = FALSE) | ||||||||
| elements$panel.spacing.x <- elements$panel.margin.x | ||||||||
| elements$panel.margin.x <- NULL | ||||||||
| } | ||||||||
| if (!is.null(elements$panel.margin.y)) { | ||||||||
| warning("`panel.margin` is deprecated. Please use `panel.spacing` property ", | ||||||||
| "instead", call. = FALSE) | ||||||||
| elements$panel.spacing.y <- elements$panel.margin.y | ||||||||
| elements$panel.margin.y <- NULL | ||||||||
| } | ||||||||
| if (is.unit(elements$legend.margin) && !is.margin(elements$legend.margin)) { | ||||||||
| warning("`legend.margin` must be specified using `margin()`. For the old ", | ||||||||
| "behavior use legend.spacing", call. = FALSE) | ||||||||
| elements$legend.spacing <- elements$legend.margin | ||||||||
| elements$legend.margin <- margin() | ||||||||
| } | ||||||||
| # Check that all elements have the correct class (element_text, unit, etc) | ||||||||
| if (validate) { | ||||||||
| mapply(validate_element, elements, names(elements)) | ||||||||
| } | ||||||||
| # If complete theme set all non-blank elements to inherit from blanks | ||||||||
| if (complete) { | ||||||||
| elements <- lapply(elements, function(el) { | ||||||||
| if (inherits(el, "element") && !inherits(el, "element_blank")) { | ||||||||
| el$inherit.blank <- TRUE | ||||||||
| } | ||||||||
| el | ||||||||
| }) | ||||||||
| } | ||||||||
| structure( | ||||||||
| elements, | ||||||||
| class = c("theme", "gg"), | ||||||||
| complete = complete, | ||||||||
| validate = validate | ||||||||
| ) | ||||||||
| } | ||||||||
| is_theme_complete <- function(x) isTRUE(attr(x, "complete")) | ||||||||
| # Combine plot defaults with current theme to get complete theme for a plot | ||||||||
| plot_theme <- function(x, default = theme_get()) { | ||||||||
| theme <- x$theme | ||||||||
| if (is_theme_complete(theme)) { | ||||||||
| theme | ||||||||
| } else { | ||||||||
| defaults(theme, default) | ||||||||
| } | ||||||||
| } | ||||||||
| #' Modify properties of an element in a theme object | ||||||||
| #' | ||||||||
| #' @param t1 A theme object | ||||||||
| #' @param t2 A theme object that is to be added to `t1` | ||||||||
| #' @param t2name A name of the t2 object. This is used for printing | ||||||||
| #' informative error messages. | ||||||||
| #' @keywords internal | ||||||||
| add_theme <- function(t1, t2, t2name) { | ||||||||
| if (!is.theme(t2)) { | ||||||||
| stop("Don't know how to add RHS to a theme object", | ||||||||
| call. = FALSE) | ||||||||
| } | ||||||||
| # Iterate over the elements that are to be updated | ||||||||
| for (item in names(t2)) { | ||||||||
| x <- t1[[item]] | ||||||||
| y <- t2[[item]] | ||||||||
| if (is.null(x) || inherits(x, "element_blank")) { | ||||||||
| # If x is NULL or element_blank, then just assign it y | ||||||||
| x <- y | ||||||||
| } else if (is.null(y) || is.character(y) || is.numeric(y) || | ||||||||
| is.logical(y) || inherits(y, "element_blank")) { | ||||||||
| # If y is NULL, or a string or numeric vector, or is element_blank, just replace x | ||||||||
| x <- y | ||||||||
| } else { | ||||||||
| # If x is not NULL, then merge into y | ||||||||
| x <- merge_element(y, x) | ||||||||
| } | ||||||||
| # Assign it back to t1 | ||||||||
| # This is like doing t1[[item]] <- x, except that it preserves NULLs. | ||||||||
| # The other form will simply drop NULL values | ||||||||
| t1[item] <- list(x) | ||||||||
| } | ||||||||
| # If either theme is complete, then the combined theme is complete | ||||||||
| attr(t1, "complete") <- is_theme_complete(t1) || is_theme_complete(t2) | ||||||||
| t1 | ||||||||
| } | ||||||||
| # Update a theme from a plot object | ||||||||
| # | ||||||||
| # This is called from add_ggplot. | ||||||||
| # | ||||||||
| # If newtheme is a *complete* theme, then it is meant to replace | ||||||||
| # oldtheme; this function just returns newtheme. | ||||||||
| # | ||||||||
| # Otherwise, it adds elements from newtheme to oldtheme: | ||||||||
| # If oldtheme doesn't already contain those elements, | ||||||||
| # it searches the current default theme, grabs the elements with the | ||||||||
| # same name as those from newtheme, and puts them in oldtheme. Then | ||||||||
| # it adds elements from newtheme to oldtheme. | ||||||||
| # This makes it possible to do things like: | ||||||||
| # ggplot(data.frame(x = 1:3, y = 1:3)) + | ||||||||
| # geom_point() + theme(text = element_text(colour = 'red')) | ||||||||
| # and have 'text' keep properties from the default theme. Otherwise | ||||||||
| # you would have to set all the element properties, like family, size, | ||||||||
| # etc. | ||||||||
| # | ||||||||
| # @param oldtheme an existing theme, usually from a plot object, like | ||||||||
| # plot$theme. This could be an empty list. | ||||||||
| # @param newtheme a new theme object to add to the existing theme | ||||||||
| update_theme <- function(oldtheme, newtheme) { | ||||||||
| # If the newtheme is a complete one, don't bother searching | ||||||||
| # the default theme -- just replace everything with newtheme | ||||||||
| if (is_theme_complete(newtheme)) | ||||||||
| return(newtheme) | ||||||||
| # These are elements in newtheme that aren't already set in oldtheme. | ||||||||
| # They will be pulled from the default theme. | ||||||||
| newitems <- !names(newtheme) %in% names(oldtheme) | ||||||||
| newitem_names <- names(newtheme)[newitems] | ||||||||
| oldtheme[newitem_names] <- theme_get()[newitem_names] | ||||||||
| # Update the theme elements with the things from newtheme | ||||||||
| # Turn the 'theme' list into a proper theme object first, and preserve | ||||||||
| # the 'complete' attribute. It's possible that oldtheme is an empty | ||||||||
| # list, and in that case, set complete to FALSE. | ||||||||
| old.validate <- isTRUE(attr(oldtheme, "validate")) | ||||||||
| new.validate <- isTRUE(attr(newtheme, "validate")) | ||||||||
| oldtheme <- do.call(theme, c(oldtheme, | ||||||||
| complete = isTRUE(attr(oldtheme, "complete")), | ||||||||
| validate = old.validate & new.validate)) | ||||||||
| oldtheme + newtheme | ||||||||
| } | ||||||||
| #' Calculate the element properties, by inheriting properties from its parents | ||||||||
| #' | ||||||||
| #' @param element The name of the theme element to calculate | ||||||||
| #' @param theme A theme object (like [theme_grey()]) | ||||||||
| #' @param verbose If TRUE, print out which elements this one inherits from | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' t <- theme_grey() | ||||||||
| #' calc_element('text', t) | ||||||||
| #' | ||||||||
| #' # Compare the "raw" element definition to the element with calculated inheritance | ||||||||
| #' t$axis.text.x | ||||||||
| #' calc_element('axis.text.x', t, verbose = TRUE) | ||||||||
| #' | ||||||||
| #' # This reports that axis.text.x inherits from axis.text, | ||||||||
| #' # which inherits from text. You can view each of them with: | ||||||||
| #' t$axis.text.x | ||||||||
| #' t$axis.text | ||||||||
| #' t$text | ||||||||
| calc_element <- function(element, theme, verbose = FALSE) { | ||||||||
| if (verbose) message(element, " --> ", appendLF = FALSE) | ||||||||
| # If this is element_blank, don't inherit anything from parents | ||||||||
| if (inherits(theme[[element]], "element_blank")) { | ||||||||
| if (verbose) message("element_blank (no inheritance)") | ||||||||
| return(theme[[element]]) | ||||||||
| } | ||||||||
| # If the element is defined (and not just inherited), check that | ||||||||
| # it is of the class specified in .element_tree | ||||||||
| if (!is.null(theme[[element]]) && | ||||||||
| !inherits(theme[[element]], ggplot_global$element_tree[[element]]$class)) { | ||||||||
| stop(element, " should have class ", ggplot_global$element_tree[[element]]$class) | ||||||||
| } | ||||||||
| # Get the names of parents from the inheritance tree | ||||||||
| pnames <- ggplot_global$element_tree[[element]]$inherit | ||||||||
| # If no parents, this is a "root" node. Just return this element. | ||||||||
| if (is.null(pnames)) { | ||||||||
| # Check that all the properties of this element are non-NULL | ||||||||
| nullprops <- vapply(theme[[element]], is.null, logical(1)) | ||||||||
| if (any(nullprops)) { | ||||||||
| stop("Theme element '", element, "' has NULL property: ", | ||||||||
| paste(names(nullprops)[nullprops], collapse = ", ")) | ||||||||
| } | ||||||||
| if (verbose) message("nothing (top level)") | ||||||||
| return(theme[[element]]) | ||||||||
| } | ||||||||
| # Calculate the parent objects' inheritance | ||||||||
| if (verbose) message(paste(pnames, collapse = ", ")) | ||||||||
| parents <- lapply(pnames, calc_element, theme, verbose) | ||||||||
| # Combine the properties of this element with all parents | ||||||||
| Reduce(combine_elements, parents, theme[[element]]) | ||||||||
| } | ||||||||
| #' Merge a parent element into a child element | ||||||||
| #' | ||||||||
| #' This is a generic and element classes must provide an implementation of this | ||||||||
| #' method | ||||||||
| #' | ||||||||
| #' @param new The child element in the theme hierarchy | ||||||||
| #' @param old The parent element in the theme hierarchy | ||||||||
| #' @return A modified version of `new` updated with the properties of | ||||||||
| #' `old` | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' new <- element_text(colour = "red") | ||||||||
| #' old <- element_text(colour = "blue", size = 10) | ||||||||
| #' | ||||||||
| #' # Adopt size but ignore colour | ||||||||
| #' merge_element(new, old) | ||||||||
| #' | ||||||||
| merge_element <- function(new, old) { | ||||||||
| UseMethod("merge_element") | ||||||||
| } | ||||||||
| #' @rdname merge_element | ||||||||
| #' @export | ||||||||
| merge_element.default <- function(new, old) { | ||||||||
| stop("No method for merging ", class(new)[1], " into ", class(old)[1], call. = FALSE) | ||||||||
| } | ||||||||
| #' @rdname merge_element | ||||||||
| #' @export | ||||||||
| merge_element.element <- function(new, old) { | ||||||||
| if (!inherits(new, class(old)[1])) { | ||||||||
| stop("Only elements of the same class can be merged", call. = FALSE) | ||||||||
| } | ||||||||
| # Override NULL properties of new with the values in old | ||||||||
| # Get logical vector of NULL properties in new | ||||||||
| idx <- vapply(new, is.null, logical(1)) | ||||||||
| # Get the names of TRUE items | ||||||||
| idx <- names(idx[idx]) | ||||||||
| # Update non-NULL items | ||||||||
| new[idx] <- old[idx] | ||||||||
| new | ||||||||
| } | ||||||||
| # Combine the properties of two elements | ||||||||
| # | ||||||||
| # @param e1 An element object | ||||||||
| # @param e2 An element object which e1 inherits from | ||||||||
| combine_elements <- function(e1, e2) { | ||||||||
| # If e2 is NULL, nothing to inherit | ||||||||
| if (is.null(e2) || inherits(e1, "element_blank")) return(e1) | ||||||||
| # If e1 is NULL inherit everything from e2 | ||||||||
| if (is.null(e1)) return(e2) | ||||||||
| # If e2 is element_blank, and e1 inherits blank inherit everything from e2, | ||||||||
| # otherwise ignore e2 | ||||||||
| if (inherits(e2, "element_blank")) { | ||||||||
| if (e1$inherit.blank) return(e2) | ||||||||
| else return(e1) | ||||||||
| } | ||||||||
| # If e1 has any NULL properties, inherit them from e2 | ||||||||
| n <- vapply(e1[names(e2)], is.null, logical(1)) | ||||||||
| e1[n] <- e2[n] | ||||||||
| # Calculate relative sizes | ||||||||
| if (is.rel(e1$size)) { | ||||||||
| e1$size <- e2$size * unclass(e1$size) | ||||||||
| } | ||||||||
| e1 | ||||||||
| } | ||||||||
| #' Reports whether x is a theme object | ||||||||
| #' @param x An object to test | ||||||||
| #' @export | ||||||||
| #' @keywords internal | ||||||||
| is.theme <- function(x) inherits(x, "theme") | ||||||||
| #' @export | ||||||||
| print.theme <- function(x, ...) utils::str(x) | ||||||||
| ggplot2/R/grob-null.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' The zero grob draws nothing and has zero size. | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| zeroGrob <- function() .zeroGrob | ||||||||
| .zeroGrob <- grob(cl = "zeroGrob", name = "NULL") | ||||||||
| #' @export | ||||||||
| #' @method widthDetails zeroGrob | ||||||||
| widthDetails.zeroGrob <- function(x) unit(0, "cm") | ||||||||
| #' @export | ||||||||
| #' @method heightDetails zeroGrob | ||||||||
| heightDetails.zeroGrob <- function(x) unit(0, "cm") | ||||||||
| #' @export | ||||||||
| #' @method grobWidth zeroGrob | ||||||||
| grobWidth.zeroGrob <- function(x) unit(0, "cm") | ||||||||
| #' @export | ||||||||
| #' @method grobHeight zeroGrob | ||||||||
| grobHeight.zeroGrob <- function(x) unit(0, "cm") | ||||||||
| #' @export | ||||||||
| #' @method drawDetails zeroGrob | ||||||||
| drawDetails.zeroGrob <- function(x, recording) {} | ||||||||
| is.zero <- function(x) is.null(x) || inherits(x, "zeroGrob") | ||||||||
| gtable/R/gtable-layouts.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Create a single column gtable. | ||||||||
| #' | ||||||||
| #' @inheritParams gtable | ||||||||
| #' @inheritParams gtable_add_grob | ||||||||
| #' @param width a unit vector giving the width of this column | ||||||||
| #' @param vp a grid viewport object (or NULL). | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' library(grid) | ||||||||
| #' a <- rectGrob(gp = gpar(fill = "red")) | ||||||||
| #' b <- circleGrob() | ||||||||
| #' c <- linesGrob() | ||||||||
| #' gt <- gtable_col("demo", list(a, b, c)) | ||||||||
| #' gt | ||||||||
| #' plot(gt) | ||||||||
| #' gtable_show_layout(gt) | ||||||||
| gtable_col <- function(name, grobs, width = NULL, heights = NULL, | ||||||||
| z = NULL, vp = NULL) { | ||||||||
| width <- width %||% unit(max(unlist(lapply(grobs, width_cm))), "cm") | ||||||||
| heights <- heights %||% rep(unit(1, "null"), length(grobs)) | ||||||||
| # z is either NULL, or a vector of the same length as grobs | ||||||||
| if (!(is.null(z) || length(z) == length(grobs))) stop("z must be either NULL or the same length as grobs", call. = FALSE) | ||||||||
| if (is.null(z)) { | ||||||||
| z <- Inf | ||||||||
| } | ||||||||
| table <- gtable(name = name, vp = vp) | ||||||||
| table <- gtable_add_rows(table, heights) | ||||||||
| table <- gtable_add_cols(table, width) | ||||||||
| table <- gtable_add_grob(table, grobs, | ||||||||
| t = seq_along(grobs), l = 1, | ||||||||
| z = z, clip = "off" | ||||||||
| ) | ||||||||
| table | ||||||||
| } | ||||||||
| #' Create a single row gtable. | ||||||||
| #' | ||||||||
| #' @inheritParams gtable | ||||||||
| #' @inheritParams gtable_add_grob | ||||||||
| #' @param height a unit vector giving the height of this row | ||||||||
| #' @param vp a grid viewport object (or NULL). | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' library(grid) | ||||||||
| #' a <- rectGrob(gp = gpar(fill = "red")) | ||||||||
| #' b <- circleGrob() | ||||||||
| #' c <- linesGrob() | ||||||||
| #' gt <- gtable_row("demo", list(a, b, c)) | ||||||||
| #' gt | ||||||||
| #' plot(gt) | ||||||||
| #' gtable_show_layout(gt) | ||||||||
| gtable_row <- function(name, grobs, height = NULL, widths = NULL, | ||||||||
| z = NULL, vp = NULL) { | ||||||||
| height <- height %||% unit(max(unlist(lapply(grobs, height_cm))), "cm") | ||||||||
| widths <- widths %||% rep(unit(1, "null"), length(grobs)) | ||||||||
| # z is either NULL, or a vector of the same length as grobs | ||||||||
| if (!(is.null(z) || length(z) == length(grobs))) stop("z must be either NULL or the same length as grobs", call. = FALSE) | ||||||||
| if (is.null(z)) { | ||||||||
| z <- Inf | ||||||||
| } | ||||||||
| table <- gtable(name = name, vp = vp) | ||||||||
| table <- gtable_add_cols(table, widths) | ||||||||
| table <- gtable_add_rows(table, height) | ||||||||
| table <- gtable_add_grob(table, grobs, | ||||||||
| l = seq_along(grobs), t = 1, | ||||||||
| z = z, clip = "off" | ||||||||
| ) | ||||||||
| table | ||||||||
| } | ||||||||
| #' Create a gtable from a matrix of grobs. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @inheritParams gtable | ||||||||
| #' @inheritParams gtable_add_grob | ||||||||
| #' @param z a numeric matrix of the same dimensions as `grobs`, | ||||||||
| #' specifying the order that the grobs are drawn. | ||||||||
| #' @param vp a grid viewport object (or NULL). | ||||||||
| #' @examples | ||||||||
| #' library(grid) | ||||||||
| #' a <- rectGrob(gp = gpar(fill = "red")) | ||||||||
| #' b <- circleGrob() | ||||||||
| #' c <- linesGrob() | ||||||||
| #' | ||||||||
| #' row <- matrix(list(a, b, c), nrow = 1) | ||||||||
| #' col <- matrix(list(a, b, c), ncol = 1) | ||||||||
| #' mat <- matrix(list(a, b, c, nullGrob()), nrow = 2) | ||||||||
| #' | ||||||||
| #' gtable_matrix("demo", row, unit(c(1, 1, 1), "null"), unit(1, "null")) | ||||||||
| #' gtable_matrix("demo", col, unit(1, "null"), unit(c(1, 1, 1), "null")) | ||||||||
| #' gtable_matrix("demo", mat, unit(c(1, 1), "null"), unit(c(1, 1), "null")) | ||||||||
| #' | ||||||||
| #' # Can specify z ordering | ||||||||
| #' z <- matrix(c(3, 1, 2, 4), nrow = 2) | ||||||||
| #' gtable_matrix("demo", mat, unit(c(1, 1), "null"), unit(c(1, 1), "null"), z = z) | ||||||||
| gtable_matrix <- function(name, grobs, widths = NULL, heights = NULL, | ||||||||
| z = NULL, respect = FALSE, clip = "on", vp = NULL) { | ||||||||
| table <- gtable(name = name, respect = respect, vp = vp) | ||||||||
| if (length(widths) != ncol(grobs)) stop("width must be the same as the number of columns in grob", call. = FALSE) | ||||||||
| if (length(heights) != nrow(grobs)) stop("height must be the same as the number of rows in grob", call. = FALSE) | ||||||||
| # z is either NULL or a matrix of the same dimensions as grobs | ||||||||
| if (!(is.null(z) || identical(dim(grobs), dim(z)))) stop("z must be either NULL or have the same dimensions as grobs", call. = FALSE) | ||||||||
| if (is.null(z)) { | ||||||||
| z <- Inf | ||||||||
| } | ||||||||
| table <- gtable_add_cols(table, widths) | ||||||||
| table <- gtable_add_rows(table, heights) | ||||||||
| table <- gtable_add_grob(table, grobs, | ||||||||
| t = c(row(grobs)), l = c(col(grobs)), | ||||||||
| z = as.vector(z), clip = clip | ||||||||
| ) | ||||||||
| table | ||||||||
| } | ||||||||
| #' Create a row/col spacer gtable. | ||||||||
| #' | ||||||||
| #' @name gtable_spacer | ||||||||
| NULL | ||||||||
| #' @param widths unit vector of widths | ||||||||
| #' @rdname gtable_spacer | ||||||||
| #' @export | ||||||||
| gtable_row_spacer <- function(widths) { | ||||||||
| gtable_add_cols(gtable(), widths) | ||||||||
| } | ||||||||
| #' @param heights unit vector of heights | ||||||||
| #' @rdname gtable_spacer | ||||||||
| #' @export | ||||||||
| gtable_col_spacer <- function(heights) { | ||||||||
| gtable_add_rows(gtable(), heights) | ||||||||
| } | ||||||||
| gtable/R/utils.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| neg_to_pos <- function(x, max) { | ||||||||
| ifelse(x >= 0, x, max + 1 + x) | ||||||||
| } | ||||||||
| compare_unit <- function(x, y, comp = `=`) { | ||||||||
| if (length(x) == 0) return(y) | ||||||||
| if (length(y) == 0) return(x) | ||||||||
| x_val <- unclass(x) | ||||||||
| y_val <- unclass(y) | ||||||||
| x_unit <- attr(x, "unit") | ||||||||
| y_unit <- attr(x, "unit") | ||||||||
| if (!all(x_unit == y_unit)) { | ||||||||
| stop("Comparison of units with different types currently not supported") | ||||||||
| } | ||||||||
| unit(comp(x_val, y_val), x_unit) | ||||||||
| } | ||||||||
| insert.unit <- function(x, values, after = length(x)) { | ||||||||
| lengx <- length(x) | ||||||||
| if (lengx == 0) return(values) | ||||||||
| if (length(values) == 0) return(x) | ||||||||
| if (after <= 0) { | ||||||||
| unit.c(values, x) | ||||||||
| } else if (after >= lengx) { | ||||||||
| unit.c(x, values) | ||||||||
| } else { | ||||||||
| unit.c(x[1L:after], values, x[(after + 1L):lengx]) | ||||||||
| } | ||||||||
| } | ||||||||
| "%||%" <- function(a, b) { | ||||||||
| if (!is.null(a)) a else b | ||||||||
| } | ||||||||
| width_cm <- function(x) { | ||||||||
| if (is.grob(x)) { | ||||||||
| convertWidth(grobWidth(x), "cm", TRUE) | ||||||||
| } else if (is.list(x)) { | ||||||||
| vapply(x, width_cm, numeric(1)) | ||||||||
| } else if (is.unit(x)) { | ||||||||
| convertWidth(x, "cm", TRUE) | ||||||||
| } else { | ||||||||
| stop("Unknown input") | ||||||||
| } | ||||||||
| } | ||||||||
| height_cm <- function(x) { | ||||||||
| if (is.grob(x)) { | ||||||||
| convertWidth(grobHeight(x), "cm", TRUE) | ||||||||
| } else if (is.list(x)) { | ||||||||
| vapply(x, height_cm, numeric(1)) | ||||||||
| } else if (is.unit(x)) { | ||||||||
| convertHeight(x, "cm", TRUE) | ||||||||
| } else { | ||||||||
| stop("Unknown input") | ||||||||
| } | ||||||||
| } | ||||||||
| # Check that x is same length as g, or length 1 | ||||||||
| len_same_or_1 <- function(x, n) { | ||||||||
| length(x) == 1 || length(x) == n | ||||||||
| } | ||||||||
| gtable/R/gtable.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Create a new grob table. | ||||||||
| #' | ||||||||
| #' A grob table captures all the information needed to layout grobs in a table | ||||||||
| #' structure. It supports row and column spanning, offers some tools to | ||||||||
| #' automatically figure out the correct dimensions, and makes it easy to | ||||||||
| #' align and combine multiple tables. | ||||||||
| #' | ||||||||
| #' Each grob is put in its own viewport - grobs in the same location are | ||||||||
| #' not combined into one cell. Each grob takes up the entire cell viewport | ||||||||
| #' so justification control is not available. | ||||||||
| #' | ||||||||
| #' It constructs both the viewports and the gTree needed to display the table. | ||||||||
| #' | ||||||||
| #' @section Components: | ||||||||
| #' | ||||||||
| #' There are three basics components to a grob table: the specification of | ||||||||
| #' table (cell heights and widths), the layout (for each grob, its position, | ||||||||
| #' name and other settings), and global parameters. | ||||||||
| #' | ||||||||
| #' It's easier to understand how `gtable` works if in your head you keep | ||||||||
| #' the table separate from it's contents. Each cell can have 0, 1, or many | ||||||||
| #' grobs inside. Each grob must belong to at least one cell, but can span | ||||||||
| #' across many cells. | ||||||||
| #' | ||||||||
| #' @section Layout: | ||||||||
| #' | ||||||||
| #' The layout details are stored in a data frame with one row for each grob, | ||||||||
| #' and columns: | ||||||||
| #' | ||||||||
| #' \itemize{ | ||||||||
| #' \item `t` top extent of grob | ||||||||
| #' \item `r` right extent of grob | ||||||||
| #' \item `b` bottom extent of | ||||||||
| #' \item `l` left extent of grob | ||||||||
| #' \item `z` the z-order of the grob - used to reorder the grobs | ||||||||
| #' before they are rendered | ||||||||
| #' \item `clip` a string, specifying how the grob should be clipped: | ||||||||
| #' either `"on"`, `"off"` or `"inherit"` | ||||||||
| #' \item `name`, a character vector used to name each grob and its | ||||||||
| #' viewport | ||||||||
| #' } | ||||||||
| #' | ||||||||
| #' You should not need to modify this data frame directly - instead use | ||||||||
| #' functions like `gtable_add_grob`. | ||||||||
| #' | ||||||||
| #' @param widths a unit vector giving the width of each column | ||||||||
| #' @param heights a unit vector giving the height of each row | ||||||||
| #' @param respect a logical vector of length 1: should the aspect ratio of | ||||||||
| #' height and width specified in null units be respected. See | ||||||||
| #' [grid.layout()] for more details | ||||||||
| #' @param name a string giving the name of the table. This is used to name | ||||||||
| #' the layout viewport | ||||||||
| #' @param rownames,colnames character vectors of row and column names, used | ||||||||
| #' for characteric subsetting, particularly for `gtable_align`, | ||||||||
| #' and `gtable_join`. | ||||||||
| #' @param vp a grid viewport object (or NULL). | ||||||||
| #' @export | ||||||||
| #' @aliases gtable-package | ||||||||
| #' @seealso [gtable_row()], [gtable_col()] and | ||||||||
| #' [gtable_matrix()] for convenient ways of creating gtables. | ||||||||
| #' @examples | ||||||||
| #' library(grid) | ||||||||
| #' a <- gtable(unit(1:3, c("cm")), unit(5, "cm")) | ||||||||
| #' a | ||||||||
| #' gtable_show_layout(a) | ||||||||
| #' | ||||||||
| #' # Add a grob: | ||||||||
| #' rect <- rectGrob(gp = gpar(fill = "black")) | ||||||||
| #' a <- gtable_add_grob(a, rect, 1, 1) | ||||||||
| #' a | ||||||||
| #' plot(a) | ||||||||
| #' | ||||||||
| #' # gtables behave like matrices: | ||||||||
| #' dim(a) | ||||||||
| #' t(a) | ||||||||
| #' plot(t(a)) | ||||||||
| #' | ||||||||
| #' # when subsetting, grobs are retained if their extents lie in the | ||||||||
| #' # rows/columns that retained. | ||||||||
| #' | ||||||||
| #' b <- gtable(unit(c(2, 2, 2), "cm"), unit(c(2, 2, 2), "cm")) | ||||||||
| #' b <- gtable_add_grob(b, rect, 2, 2) | ||||||||
| #' b[1, ] | ||||||||
| #' b[, 1] | ||||||||
| #' b[2, 2] | ||||||||
| #' | ||||||||
| #' # gtable have row and column names | ||||||||
| #' rownames(b) <- 1:3 | ||||||||
| #' rownames(b)[2] <- 200 | ||||||||
| #' colnames(b) <- letters[1:3] | ||||||||
| #' dimnames(b) | ||||||||
| gtable <- function(widths = list(), heights = list(), respect = FALSE, | ||||||||
| name = "layout", rownames = NULL, colnames = NULL, vp = NULL) { | ||||||||
| if (length(widths) > 0) { | ||||||||
| if (!is.unit(widths)) stop("widths must be a unit object", call. = FALSE) | ||||||||
| if (!(is.null(colnames) || length(colnames == length(widths)))) stop("colnames must either be NULL or have the same length as widths", call. = FALSE) | ||||||||
| } | ||||||||
| if (length(heights) > 0) { | ||||||||
| if (!is.unit(heights)) stop("heights must be a unit object", call. = FALSE) | ||||||||
| if (!(is.null(rownames) || length(rownames == length(heights)))) stop("rownames must either be NULL or have the same length as heights", call. = FALSE) | ||||||||
| } | ||||||||
| layout <- new_data_frame(list( | ||||||||
| t = numeric(), l = numeric(), b = numeric(), r = numeric(), z = numeric(), | ||||||||
| clip = character(), name = character() | ||||||||
| ), n = 0) | ||||||||
| if (!is.null(vp)) { | ||||||||
| vp <- viewport( | ||||||||
| name = name, | ||||||||
| x = vp$x, y = vp$y, | ||||||||
| width = vp$width, height = vp$height, | ||||||||
| just = vp$just, gp = vp$gp, xscale = vp$xscale, | ||||||||
| yscale = vp$yscale, angle = vp$angle, clip = vp$clip | ||||||||
| ) | ||||||||
| } | ||||||||
| gTree( | ||||||||
| grobs = list(), layout = layout, widths = widths, | ||||||||
| heights = heights, respect = respect, name = name, | ||||||||
| rownames = rownames, colnames = colnames, vp = vp, | ||||||||
| cl = "gtable" | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Print a gtable object | ||||||||
| #' | ||||||||
| #' @param x A gtable object. | ||||||||
| #' @param zsort Sort by z values? Default `FALSE`. | ||||||||
| #' @param ... Other arguments (not used by this method). | ||||||||
| #' @export | ||||||||
| #' @method print gtable | ||||||||
| print.gtable <- function(x, zsort = FALSE, ...) { | ||||||||
| cat("TableGrob (", length(x$heights), " x ", length(x$widths), ") \"", x$name, "\": ", | ||||||||
| length(x$grobs), " grobs\n", sep = "") | ||||||||
| if (nrow(x$layout) == 0) return() | ||||||||
| pos <- as.data.frame(format(as.matrix(x$layout[c("t", "r", "b", "l")])), | ||||||||
| stringsAsFactors = FALSE | ||||||||
| ) | ||||||||
| grobNames <- vapply(x$grobs, as.character, character(1)) | ||||||||
| info <- data.frame( | ||||||||
| z = x$layout$z, | ||||||||
| cells = paste("(", pos$t, "-", pos$b, ",", pos$l, "-", pos$r, ")", sep = ""), | ||||||||
| name = x$layout$name, | ||||||||
| grob = grobNames | ||||||||
| ) | ||||||||
| if (zsort) info <- info[order(x$layout$z), ] | ||||||||
| print(info) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| dim.gtable <- function(x) c(length(x$heights), length(x$widths)) | ||||||||
| #' @export | ||||||||
| dimnames.gtable <- function(x, ...) list(x$rownames, x$colnames) | ||||||||
| #' @export | ||||||||
| "dimnames<-.gtable" <- function(x, value) { | ||||||||
| x$rownames <- value[[1]] | ||||||||
| x$colnames <- value[[2]] | ||||||||
| if (anyDuplicated(x$rownames)) { | ||||||||
| stop("rownames must be distinct", | ||||||||
| call. = FALSE | ||||||||
| ) | ||||||||
| } | ||||||||
| if (anyDuplicated(x$colnames)) { | ||||||||
| stop("colnames must be distinct", | ||||||||
| call. = FALSE | ||||||||
| ) | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| #' @export | ||||||||
| plot.gtable <- function(x, ...) { | ||||||||
| grid.newpage() | ||||||||
| grid.rect(gp = gpar(fill = "grey95")) | ||||||||
| grid <- seq(0, 1, length = 20) | ||||||||
| grid.grill(h = grid, v = grid, gp = gpar(col = "white")) | ||||||||
| grid.draw(x) | ||||||||
| } | ||||||||
| #' Is this a gtable? | ||||||||
| #' | ||||||||
| #' @param x object to test | ||||||||
| #' @export | ||||||||
| is.gtable <- function(x) { | ||||||||
| inherits(x, "gtable") | ||||||||
| } | ||||||||
| #' @export | ||||||||
| t.gtable <- function(x) { | ||||||||
| new <- x | ||||||||
| layout <- unclass(x$layout) | ||||||||
| old_lay <- layout | ||||||||
| layout$t <- old_lay$l | ||||||||
| layout$r <- old_lay$b | ||||||||
| layout$b <- old_lay$r | ||||||||
| layout$l <- old_lay$t | ||||||||
| new$layout <- new_data_frame(layout) | ||||||||
| new$widths <- x$heights | ||||||||
| new$heights <- x$widths | ||||||||
| new | ||||||||
| } | ||||||||
| #' @export | ||||||||
| "[.gtable" <- function(x, i, j) { | ||||||||
| # Convert indicies to (named) numeric | ||||||||
| rows <- stats::setNames(seq_along(x$heights), rownames(x))[i] | ||||||||
| cols <- stats::setNames(seq_along(x$widths), colnames(x))[j] | ||||||||
| i <- seq_along(x$heights) %in% seq_along(x$heights)[rows] | ||||||||
| j <- seq_along(x$widths) %in% seq_along(x$widths)[cols] | ||||||||
| x$heights <- x$heights[rows] | ||||||||
| x$rownames <- x$rownames[rows] | ||||||||
| x$widths <- x$widths[cols] | ||||||||
| x$colnames <- x$colnames[cols] | ||||||||
| layout <- unclass(x$layout) | ||||||||
| keep <- layout$t %in% rows & layout$b %in% rows & | ||||||||
| layout$l %in% cols & layout$r %in% cols | ||||||||
| x$grobs <- x$grobs[keep] | ||||||||
| adj_rows <- cumsum(!i) | ||||||||
| adj_cols <- cumsum(!j) | ||||||||
| layout$r <- layout$r - adj_cols[layout$r] | ||||||||
| layout$l <- layout$l - adj_cols[layout$l] | ||||||||
| layout$t <- layout$t - adj_rows[layout$t] | ||||||||
| layout$b <- layout$b - adj_rows[layout$b] | ||||||||
| # Drop the unused rows from layout | ||||||||
| x$layout <- new_data_frame(layout)[keep, ] | ||||||||
| x | ||||||||
| } | ||||||||
| #' @export | ||||||||
| length.gtable <- function(x) length(x$grobs) | ||||||||
| #' Returns the height of a gtable, in the gtable's units | ||||||||
| #' | ||||||||
| #' Note that unlike heightDetails.gtable, this can return relative units. | ||||||||
| #' | ||||||||
| #' @param x A gtable object | ||||||||
| #' @export | ||||||||
| gtable_height <- function(x) sum(x$heights) | ||||||||
| #' Returns the width of a gtable, in the gtable's units | ||||||||
| #' | ||||||||
| #' Note that unlike widthDetails.gtable, this can return relative units. | ||||||||
| #' | ||||||||
| #' @param x A gtable object | ||||||||
| #' @export | ||||||||
| gtable_width <- function(x) sum(x$widths) | ||||||||
| gtable/R/add-space.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Add row/column spacing. | ||||||||
| #' | ||||||||
| #' Adds `width` space between the columns or `height` space between | ||||||||
| #' the rows. | ||||||||
| #' | ||||||||
| #' @name gtable_add_space | ||||||||
| #' @param x a gtable object | ||||||||
| NULL | ||||||||
| #' @param width a vector of units of length 1 or ncol - 1 | ||||||||
| #' @export | ||||||||
| #' @rdname gtable_add_space | ||||||||
| gtable_add_col_space <- function(x, width) { | ||||||||
| if (!is.gtable(x)) stop("x must be a gtable", call. = FALSE) | ||||||||
| n <- length(x$widths) - 1 | ||||||||
| if (n == 0) return(x) | ||||||||
| if (!(length(width) == 1 || length(width) == n)) stop("width must be of length 1 or ncol - 1", call. = FALSE) | ||||||||
| width <- rep(width, length.out = n) | ||||||||
| for (i in rev(seq_len(n))) { | ||||||||
| x <- gtable_add_cols(x, width[i], pos = i) | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| #' @param height a vector of units of length 1 or nrow - 1 | ||||||||
| #' @export | ||||||||
| #' @rdname gtable_add_space | ||||||||
| gtable_add_row_space <- function(x, height) { | ||||||||
| if (!is.gtable(x)) stop("x must be a gtable", call. = FALSE) | ||||||||
| n <- length(x$heights) - 1 | ||||||||
| if (n == 0) return(x) | ||||||||
| if (!(length(height) == 1 || length(height) == n)) stop("height must be of length 1 or nrow - 1", call. = FALSE) | ||||||||
| height <- rep(height, length.out = n) | ||||||||
| for (i in rev(seq_len(n))) { | ||||||||
| x <- gtable_add_rows(x, height[i], pos = i) | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| ggplot2/R/grob-absolute.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Absolute grob | ||||||||
| #' | ||||||||
| #' This grob has fixed dimensions and position. | ||||||||
| #' | ||||||||
| #' It's still experimental | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| absoluteGrob <- function(grob, width = NULL, height = NULL, | ||||||||
| xmin = NULL, ymin = NULL, vp = NULL) { | ||||||||
| gTree( | ||||||||
| children = grob, | ||||||||
| width = width, height = height, | ||||||||
| xmin = xmin, ymin = ymin, | ||||||||
| vp = vp, cl = "absoluteGrob" | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @method grobHeight absoluteGrob | ||||||||
| grobHeight.absoluteGrob <- function(x) { | ||||||||
| x$height %||% grobHeight(x$children) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @method grobWidth absoluteGrob | ||||||||
| grobWidth.absoluteGrob <- function(x) { | ||||||||
| x$width %||% grobWidth(x$children) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @method grobX absoluteGrob | ||||||||
| grobX.absoluteGrob <- function(x, theta) { | ||||||||
| if (!is.null(x$xmin) && theta == "west") return(x$xmin) | ||||||||
| grobX(x$children, theta) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @method grobY absoluteGrob | ||||||||
| grobY.absoluteGrob <- function(x, theta) { | ||||||||
| if (!is.null(x$ymin) && theta == "south") return(x$ymin) | ||||||||
| grobY(x$children, theta) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @method grid.draw absoluteGrob | ||||||||
| grid.draw.absoluteGrob <- function(x, recording = TRUE) { | ||||||||
| NextMethod() | ||||||||
| } | ||||||||
| ggplot2/R/position-.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' @section Positions: | ||||||||
| #' | ||||||||
| #' All `position_*` functions (like `position_dodge`) return a | ||||||||
| #' `Position*` object (like `PositionDodge`). The `Position*` | ||||||||
| #' object is responsible for adjusting the position of overlapping geoms. | ||||||||
| #' | ||||||||
| #' The way that the `position_*` functions work is slightly different from | ||||||||
| #' the `geom_*` and `stat_*` functions, because a `position_*` | ||||||||
| #' function actually "instantiates" the `Position*` object by creating a | ||||||||
| #' descendant, and returns that. | ||||||||
| #' | ||||||||
| #' Each of the `Position*` objects is a [ggproto()] object, | ||||||||
| #' descended from the top-level `Position`, and each implements the | ||||||||
| #' following methods: | ||||||||
| #' | ||||||||
| #' - `compute_layer(self, data, params, panel)` is called once | ||||||||
| #' per layer. `panel` is currently an internal data structure, so | ||||||||
| #' this method should not be overridden. | ||||||||
| #' | ||||||||
| #' - `compute_panel(self, data, params, panel)` is called once per | ||||||||
| #' panel and should return a modified data frame. | ||||||||
| #' | ||||||||
| #' `data` is a data frame containing the variables named according | ||||||||
| #' to the aesthetics that they're mapped to. `scales` is a list | ||||||||
| #' containing the `x` and `y` scales. There functions are called | ||||||||
| #' before the facets are trained, so they are global scales, not local | ||||||||
| #' to the individual panels. `params` contains the parameters returned by | ||||||||
| #' `setup_params()`. | ||||||||
| #' - `setup_params(data, params)`: called once for each layer. | ||||||||
| #' Used to setup defaults that need to complete dataset, and to inform | ||||||||
| #' the user of important choices. Should return list of parameters. | ||||||||
| #' - `setup_data(data, params)`: called once for each layer, | ||||||||
| #' after `setup_params()`. Should return modified `data`. | ||||||||
| #' Default checks that required aesthetics are present. | ||||||||
| #' | ||||||||
| #' And the following fields | ||||||||
| #' - `required_aes`: a character vector giving the aesthetics | ||||||||
| #' that must be present for this position adjustment to work. | ||||||||
| #' | ||||||||
| #' @rdname ggplot2-ggproto | ||||||||
| #' @format NULL | ||||||||
| #' @usage NULL | ||||||||
| #' @export | ||||||||
| Position <- ggproto("Position", | ||||||||
| required_aes = character(), | ||||||||
| setup_params = function(self, data) { | ||||||||
| list() | ||||||||
| }, | ||||||||
| setup_data = function(self, data, params) { | ||||||||
| check_required_aesthetics(self$required_aes, names(data), snake_class(self)) | ||||||||
| data | ||||||||
| }, | ||||||||
| compute_layer = function(self, data, params, layout) { | ||||||||
| plyr::ddply(data, "PANEL", function(data) { | ||||||||
| if (empty(data)) return(new_data_frame()) | ||||||||
| scales <- layout$get_scales(data$PANEL[1]) | ||||||||
| self$compute_panel(data = data, params = params, scales = scales) | ||||||||
| }) | ||||||||
| }, | ||||||||
| compute_panel = function(self, data, params, scales) { | ||||||||
| stop("Not implemented", call. = FALSE) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' Convenience function to transform all position variables. | ||||||||
| #' | ||||||||
| #' @param trans_x,trans_y Transformation functions for x and y aesthetics. | ||||||||
| #' (will transform x, xmin, xmax, xend etc) | ||||||||
| #' @param ... Additional arguments passed to `trans_x` and `trans_y`. | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| transform_position <- function(df, trans_x = NULL, trans_y = NULL, ...) { | ||||||||
| scales <- aes_to_scale(names(df)) | ||||||||
| if (!is.null(trans_x)) { | ||||||||
| df[scales == "x"] <- lapply(df[scales == "x"], trans_x, ...) | ||||||||
| } | ||||||||
| if (!is.null(trans_y)) { | ||||||||
| df[scales == "y"] <- lapply(df[scales == "y"], trans_y, ...) | ||||||||
| } | ||||||||
| df | ||||||||
| } | ||||||||
| ggplot2/R/coord-cartesian-.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Cartesian coordinates | ||||||||
| #' | ||||||||
| #' The Cartesian coordinate system is the most familiar, and common, type of | ||||||||
| #' coordinate system. Setting limits on the coordinate system will zoom the | ||||||||
| #' plot (like you're looking at it with a magnifying glass), and will not | ||||||||
| #' change the underlying data like setting limits on a scale will. | ||||||||
| #' | ||||||||
| #' @param xlim,ylim Limits for the x and y axes. | ||||||||
| #' @param expand If `TRUE`, the default, adds a small expansion factor to | ||||||||
| #' the limits to ensure that data and axes don't overlap. If `FALSE`, | ||||||||
| #' limits are taken exactly from the data or `xlim`/`ylim`. | ||||||||
| #' @param default Is this the default coordinate system? If `FALSE` (the default), | ||||||||
| #' then replacing this coordinate system with another one creates a message alerting | ||||||||
| #' the user that the coordinate system is being replaced. If `TRUE`, that warning | ||||||||
| #' is suppressed. | ||||||||
| #' @param clip Should drawing be clipped to the extent of the plot panel? A | ||||||||
| #' setting of `"on"` (the default) means yes, and a setting of `"off"` | ||||||||
| #' means no. In most cases, the default of `"on"` should not be changed, | ||||||||
| #' as setting `clip = "off"` can cause unexpected results. It allows | ||||||||
| #' drawing of data points anywhere on the plot, including in the plot margins. If | ||||||||
| #' limits are set via `xlim` and `ylim` and some data points fall outside those | ||||||||
| #' limits, then those data points may show up in places such as the axes, the | ||||||||
| #' legend, the plot title, or the plot margins. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # There are two ways of zooming the plot display: with scales or | ||||||||
| #' # with coordinate systems. They work in two rather different ways. | ||||||||
| #' | ||||||||
| #' p <- ggplot(mtcars, aes(disp, wt)) + | ||||||||
| #' geom_point() + | ||||||||
| #' geom_smooth() | ||||||||
| #' p | ||||||||
| #' | ||||||||
| #' # Setting the limits on a scale converts all values outside the range to NA. | ||||||||
| #' p + scale_x_continuous(limits = c(325, 500)) | ||||||||
| #' | ||||||||
| #' # Setting the limits on the coordinate system performs a visual zoom. | ||||||||
| #' # The data is unchanged, and we just view a small portion of the original | ||||||||
| #' # plot. Note how smooth continues past the points visible on this plot. | ||||||||
| #' p + coord_cartesian(xlim = c(325, 500)) | ||||||||
| #' | ||||||||
| #' # By default, the same expansion factor is applied as when setting scale | ||||||||
| #' # limits. You can set the limits precisely by setting expand = FALSE | ||||||||
| #' p + coord_cartesian(xlim = c(325, 500), expand = FALSE) | ||||||||
| #' | ||||||||
| #' # Simiarly, we can use expand = FALSE to turn off expansion with the | ||||||||
| #' # default limits | ||||||||
| #' p + coord_cartesian(expand = FALSE) | ||||||||
| #' | ||||||||
| #' # You can see the same thing with this 2d histogram | ||||||||
| #' d <- ggplot(diamonds, aes(carat, price)) + | ||||||||
| #' stat_bin2d(bins = 25, colour = "white") | ||||||||
| #' d | ||||||||
| #' | ||||||||
| #' # When zooming the scale, the we get 25 new bins that are the same | ||||||||
| #' # size on the plot, but represent smaller regions of the data space | ||||||||
| #' d + scale_x_continuous(limits = c(0, 1)) | ||||||||
| #' | ||||||||
| #' # When zooming the coordinate system, we see a subset of original 50 bins, | ||||||||
| #' # displayed bigger | ||||||||
| #' d + coord_cartesian(xlim = c(0, 1)) | ||||||||
| coord_cartesian <- function(xlim = NULL, ylim = NULL, expand = TRUE, | ||||||||
| default = FALSE, clip = "on") { | ||||||||
| ggproto(NULL, CoordCartesian, | ||||||||
| limits = list(x = xlim, y = ylim), | ||||||||
| expand = expand, | ||||||||
| default = default, | ||||||||
| clip = clip | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @rdname ggplot2-ggproto | ||||||||
| #' @format NULL | ||||||||
| #' @usage NULL | ||||||||
| #' @export | ||||||||
| CoordCartesian <- ggproto("CoordCartesian", Coord, | ||||||||
| is_linear = function() TRUE, | ||||||||
| is_free = function() TRUE, | ||||||||
| distance = function(x, y, panel_params) { | ||||||||
| max_dist <- dist_euclidean(panel_params$x.range, panel_params$y.range) | ||||||||
| dist_euclidean(x, y) / max_dist | ||||||||
| }, | ||||||||
| range = function(panel_params) { | ||||||||
| list(x = panel_params$x.range, y = panel_params$y.range) | ||||||||
| }, | ||||||||
| backtransform_range = function(self, panel_params) { | ||||||||
| self$range(panel_params) | ||||||||
| }, | ||||||||
| transform = function(data, panel_params) { | ||||||||
| rescale_x <- function(data) rescale(data, from = panel_params$x.range) | ||||||||
| rescale_y <- function(data) rescale(data, from = panel_params$y.range) | ||||||||
| data <- transform_position(data, rescale_x, rescale_y) | ||||||||
| transform_position(data, squish_infinite, squish_infinite) | ||||||||
| }, | ||||||||
| setup_panel_params = function(self, scale_x, scale_y, params = list()) { | ||||||||
| train_cartesian <- function(scale, limits, name) { | ||||||||
| range <- scale_range(scale, limits, self$expand) | ||||||||
| out <- scale$break_info(range) | ||||||||
| out$arrange <- scale$axis_order() | ||||||||
| names(out) <- paste(name, names(out), sep = ".") | ||||||||
| out | ||||||||
| } | ||||||||
| c( | ||||||||
| train_cartesian(scale_x, self$limits$x, "x"), | ||||||||
| train_cartesian(scale_y, self$limits$y, "y") | ||||||||
| ) | ||||||||
| } | ||||||||
| ) | ||||||||
| scale_range <- function(scale, limits = NULL, expand = TRUE) { | ||||||||
| expansion <- if (expand) expand_default(scale) else c(0, 0) | ||||||||
| if (is.null(limits)) { | ||||||||
| scale$dimension(expansion) | ||||||||
| } else { | ||||||||
| range <- range(scale$transform(limits)) | ||||||||
| expand_range(range, expansion[1], expansion[2]) | ||||||||
| } | ||||||||
| } | ||||||||
| gtable/R/add-grob.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Add a single grob, possibly spanning multiple rows or columns. | ||||||||
| #' | ||||||||
| #' This only adds grobs into the table - it doesn't affect the table in | ||||||||
| #' any way. In the gtable model, grobs always fill up the complete table | ||||||||
| #' cell. If you want custom justification you might need to | ||||||||
| #' | ||||||||
| #' @param x a [gtable()] object | ||||||||
| #' @param grobs a single grob or a list of grobs | ||||||||
| #' @param t a numeric vector giving the top extent of the grobs | ||||||||
| #' @param l a numeric vector giving the left extent of the grobs | ||||||||
| #' @param b a numeric vector giving the bottom extent of the grobs | ||||||||
| #' @param r a numeric vector giving the right extent of the grobs | ||||||||
| #' @param z a numeric vector giving the order in which the grobs should be | ||||||||
| #' plotted. Use `Inf` (the default) to plot above or `-Inf` | ||||||||
| #' below all existing grobs. By default positions are on the integers, | ||||||||
| #' giving plenty of room to insert new grobs between existing grobs. | ||||||||
| #' @param clip should drawing be clipped to the specified cells | ||||||||
| #' (`"on"`), the entire table (`"inherit"`), or not at all | ||||||||
| #' (`"off"`) | ||||||||
| #' @param name name of the grob - used to modify the grob name before it's | ||||||||
| #' plotted. | ||||||||
| #' @export | ||||||||
| gtable_add_grob <- function(x, grobs, t, l, b = t, r = l, z = Inf, clip = "on", name = x$name) { | ||||||||
| if (!is.gtable(x)) stop("x must be a gtable", call. = FALSE) | ||||||||
| if (is.grob(grobs)) grobs <- list(grobs) | ||||||||
| if (!is.list(grobs)) stop("grobs must either be a single grob or a list of grobs", call. = FALSE) | ||||||||
| n_grobs <- length(grobs) | ||||||||
| layout <- unclass(x$layout) | ||||||||
| # Check that inputs have the right length | ||||||||
| if (!all(vapply( | ||||||||
| list(t, r, b, l, z, clip, name), len_same_or_1, | ||||||||
| logical(1), n_grobs | ||||||||
| ))) { | ||||||||
| stop("Not all inputs have either length 1 or same length same as 'grobs'") | ||||||||
| } | ||||||||
| # If z is just one value, replicate to same length as grobs | ||||||||
| z <- rep(z, length.out = n_grobs) | ||||||||
| # Get the existing z values from x$layout, and new non-Inf z-values | ||||||||
| zval <- c(layout$z, z[!is.infinite(z)]) | ||||||||
| if (length(zval) == 0) { | ||||||||
| # If there are no existing finite z values, set these so that | ||||||||
| # -Inf values get assigned ..., -2, -1, 0 and | ||||||||
| # +Inf values get assigned 1, 2, 3, ... | ||||||||
| zmin <- 1 | ||||||||
| zmax <- 0 | ||||||||
| } else { | ||||||||
| zmin <- min(zval) | ||||||||
| zmax <- max(zval) | ||||||||
| } | ||||||||
| z[z == -Inf] <- zmin - rev(seq_len(sum(z == -Inf))) | ||||||||
| z[z == Inf] <- zmax + seq_len(sum(z == Inf)) | ||||||||
| x_row <- length(x$heights) | ||||||||
| x_col <- length(x$widths) | ||||||||
| t <- rep(neg_to_pos(t, x_row), length.out = n_grobs) | ||||||||
| b <- rep(neg_to_pos(b, x_row), length.out = n_grobs) | ||||||||
| l <- rep(neg_to_pos(l, x_col), length.out = n_grobs) | ||||||||
| r <- rep(neg_to_pos(r, x_col), length.out = n_grobs) | ||||||||
| clip <- rep(clip, length.out = n_grobs) | ||||||||
| name <- rep(name, length.out = n_grobs) | ||||||||
| x$grobs <- c(x$grobs, grobs) | ||||||||
| x$layout <- new_data_frame(list( | ||||||||
| t = c(layout$t, t), | ||||||||
| l = c(layout$l, l), | ||||||||
| b = c(layout$b, b), | ||||||||
| r = c(layout$r, r), | ||||||||
| z = c(layout$z, z), | ||||||||
| clip = c(layout$clip, clip), | ||||||||
| name = c(layout$name, name) | ||||||||
| )) | ||||||||
| x | ||||||||
| } | ||||||||
| gtable/R/new-data-frame.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| # Fast data.frame constructor | ||||||||
| # No checking, recycling etc. unless asked for | ||||||||
| new_data_frame <- function(x, n = NULL) { | ||||||||
| if (is.null(n)) { | ||||||||
| n <- if (length(x) == 0) 0 else length(x[[1]]) | ||||||||
| } | ||||||||
| class(x) <- "data.frame" | ||||||||
| attr(x, "row.names") <- .set_row_names(n) | ||||||||
| x | ||||||||
| } | ||||||||
| validate_data_frame <- function(x) { | ||||||||
| if (length(unique(lengths(x))) != 1) stop('All elements in a data.frame must be of equal length', call. = FALSE) | ||||||||
| if (is.null(names(x))) stop('Columns must be named', call. = FALSE) | ||||||||
| } | ||||||||
| ggplot2/R/scale-continuous.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Position scales for continuous data (x & y) | ||||||||
| #' | ||||||||
| #' `scale_x_continuous()` and `scale_y_continuous()` are the default | ||||||||
| #' scales for continuous x and y aesthetics. There are three variants | ||||||||
| #' that set the `trans` argument for commonly used transformations: | ||||||||
| #' `scale_*_log10()`, `scale_*_sqrt()` and `scale_*_reverse()`. | ||||||||
| #' | ||||||||
| #' For simple manipulation of labels and limits, you may wish to use | ||||||||
| #' [labs()] and [lims()] instead. | ||||||||
| #' | ||||||||
| #' @inheritParams continuous_scale | ||||||||
| #' @family position scales | ||||||||
| #' @param ... Other arguments passed on to `scale_(x|y)_continuous()` | ||||||||
| #' @examples | ||||||||
| #' p1 <- ggplot(mpg, aes(displ, hwy)) + | ||||||||
| #' geom_point() | ||||||||
| #' p1 | ||||||||
| #' | ||||||||
| #' # Manipulating the default position scales lets you: | ||||||||
| #' # * change the axis labels | ||||||||
| #' p1 + | ||||||||
| #' scale_x_continuous("Engine displacement (L)") + | ||||||||
| #' scale_y_continuous("Highway MPG") | ||||||||
| #' | ||||||||
| #' # You can also use the short-cut labs(). | ||||||||
| #' # Use NULL to suppress axis labels | ||||||||
| #' p1 + labs(x = NULL, y = NULL) | ||||||||
| #' | ||||||||
| #' # * modify the axis limits | ||||||||
| #' p1 + scale_x_continuous(limits = c(2, 6)) | ||||||||
| #' p1 + scale_x_continuous(limits = c(0, 10)) | ||||||||
| #' | ||||||||
| #' # you can also use the short hand functions `xlim()` and `ylim()` | ||||||||
| #' p1 + xlim(2, 6) | ||||||||
| #' | ||||||||
| #' # * choose where the ticks appear | ||||||||
| #' p1 + scale_x_continuous(breaks = c(2, 4, 6)) | ||||||||
| #' | ||||||||
| #' # * choose your own labels | ||||||||
| #' p1 + scale_x_continuous( | ||||||||
| #' breaks = c(2, 4, 6), | ||||||||
| #' label = c("two", "four", "six") | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' # Typically you'll pass a function to the `labels` argument. | ||||||||
| #' # Some common formats are built into the scales package: | ||||||||
| #' df <- data.frame( | ||||||||
| #' x = rnorm(10) * 100000, | ||||||||
| #' y = seq(0, 1, length.out = 10) | ||||||||
| #' ) | ||||||||
| #' p2 <- ggplot(df, aes(x, y)) + geom_point() | ||||||||
| #' p2 + scale_y_continuous(labels = scales::percent) | ||||||||
| #' p2 + scale_y_continuous(labels = scales::dollar) | ||||||||
| #' p2 + scale_x_continuous(labels = scales::comma) | ||||||||
| #' | ||||||||
| #' # You can also override the default linear mapping by using a | ||||||||
| #' # transformation. There are three shortcuts: | ||||||||
| #' p1 + scale_y_log10() | ||||||||
| #' p1 + scale_y_sqrt() | ||||||||
| #' p1 + scale_y_reverse() | ||||||||
| #' | ||||||||
| #' # Or you can supply a transformation in the `trans` argument: | ||||||||
| #' p1 + scale_y_continuous(trans = scales::reciprocal_trans()) | ||||||||
| #' | ||||||||
| #' # You can also create your own. See ?scales::trans_new | ||||||||
| #' | ||||||||
| #' @name scale_continuous | ||||||||
| #' @aliases NULL | ||||||||
| NULL | ||||||||
| #' @rdname scale_continuous | ||||||||
| #' | ||||||||
| #' @param sec.axis specify a secondary axis | ||||||||
| #' | ||||||||
| #' @seealso [sec_axis()] for how to specify secondary axes | ||||||||
| #' @export | ||||||||
| scale_x_continuous <- function(name = waiver(), breaks = waiver(), | ||||||||
| minor_breaks = waiver(), labels = waiver(), | ||||||||
| limits = NULL, expand = waiver(), oob = censor, | ||||||||
| na.value = NA_real_, trans = "identity", | ||||||||
| position = "bottom", sec.axis = waiver()) { | ||||||||
| sc <- continuous_scale( | ||||||||
| c("x", "xmin", "xmax", "xend", "xintercept", "xmin_final", "xmax_final", "xlower", "xmiddle", "xupper"), | ||||||||
| "position_c", identity, name = name, breaks = breaks, | ||||||||
| minor_breaks = minor_breaks, labels = labels, limits = limits, | ||||||||
| expand = expand, oob = oob, na.value = na.value, trans = trans, | ||||||||
| guide = "none", position = position, super = ScaleContinuousPosition | ||||||||
| ) | ||||||||
| set_sec_axis(sec.axis, sc) | ||||||||
| } | ||||||||
| #' @rdname scale_continuous | ||||||||
| #' @export | ||||||||
| scale_y_continuous <- function(name = waiver(), breaks = waiver(), | ||||||||
| minor_breaks = waiver(), labels = waiver(), | ||||||||
| limits = NULL, expand = waiver(), oob = censor, | ||||||||
| na.value = NA_real_, trans = "identity", | ||||||||
| position = "left", sec.axis = waiver()) { | ||||||||
| sc <- continuous_scale( | ||||||||
| c("y", "ymin", "ymax", "yend", "yintercept", "ymin_final", "ymax_final", "lower", "middle", "upper"), | ||||||||
| "position_c", identity, name = name, breaks = breaks, | ||||||||
| minor_breaks = minor_breaks, labels = labels, limits = limits, | ||||||||
| expand = expand, oob = oob, na.value = na.value, trans = trans, | ||||||||
| guide = "none", position = position, super = ScaleContinuousPosition | ||||||||
| ) | ||||||||
| set_sec_axis(sec.axis, sc) | ||||||||
| } | ||||||||
| #' @rdname ggplot2-ggproto | ||||||||
| #' @format NULL | ||||||||
| #' @usage NULL | ||||||||
| #' @export | ||||||||
| ScaleContinuousPosition <- ggproto("ScaleContinuousPosition", ScaleContinuous, | ||||||||
| secondary.axis = waiver(), | ||||||||
| # Position aesthetics don't map, because the coordinate system takes | ||||||||
| # care of it. But they do need to be made in to doubles, so stat methods | ||||||||
| # can tell the difference between continuous and discrete data. | ||||||||
| map = function(self, x, limits = self$get_limits()) { | ||||||||
| scaled <- as.numeric(self$oob(x, limits)) | ||||||||
| ifelse(!is.na(scaled), scaled, self$na.value) | ||||||||
| }, | ||||||||
| break_info = function(self, range = NULL) { | ||||||||
| breaks <- ggproto_parent(ScaleContinuous, self)$break_info(range) | ||||||||
| if (!(is.waive(self$secondary.axis) || self$secondary.axis$empty())) { | ||||||||
| self$secondary.axis$init(self) | ||||||||
| breaks <- c(breaks, self$secondary.axis$break_info(breaks$range, self)) | ||||||||
| } | ||||||||
| breaks | ||||||||
| }, | ||||||||
| sec_name = function(self) { | ||||||||
| if (is.waive(self$secondary.axis)) { | ||||||||
| waiver() | ||||||||
| } else { | ||||||||
| self$secondary.axis$name | ||||||||
| } | ||||||||
| }, | ||||||||
| make_sec_title = function(self, title) { | ||||||||
| if (!is.waive(self$secondary.axis)) { | ||||||||
| self$secondary.axis$make_title(title) | ||||||||
| } else { | ||||||||
| ggproto_parent(ScaleContinuous, self)$make_sec_title(title) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| # Transformed scales --------------------------------------------------------- | ||||||||
| #' @rdname scale_continuous | ||||||||
| #' @export | ||||||||
| scale_x_log10 <- function(...) { | ||||||||
| scale_x_continuous(..., trans = log10_trans()) | ||||||||
| } | ||||||||
| #' @rdname scale_continuous | ||||||||
| #' @export | ||||||||
| scale_y_log10 <- function(...) { | ||||||||
| scale_y_continuous(..., trans = log10_trans()) | ||||||||
| } | ||||||||
| #' @rdname scale_continuous | ||||||||
| #' @export | ||||||||
| scale_x_reverse <- function(...) { | ||||||||
| scale_x_continuous(..., trans = reverse_trans()) | ||||||||
| } | ||||||||
| #' @rdname scale_continuous | ||||||||
| #' @export | ||||||||
| scale_y_reverse <- function(...) { | ||||||||
| scale_y_continuous(..., trans = reverse_trans()) | ||||||||
| } | ||||||||
| #' @rdname scale_continuous | ||||||||
| #' @export | ||||||||
| scale_x_sqrt <- function(...) { | ||||||||
| scale_x_continuous(..., trans = sqrt_trans()) | ||||||||
| } | ||||||||
| #' @rdname scale_continuous | ||||||||
| #' @export | ||||||||
| scale_y_sqrt <- function(...) { | ||||||||
| scale_y_continuous(..., trans = sqrt_trans()) | ||||||||
| } | ||||||||
| ggplot2/R/aaa-.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' @include ggplot-global.R | ||||||||
| #' @include ggproto.r | ||||||||
| NULL | ||||||||
| #' Base ggproto classes for ggplot2 | ||||||||
| #' | ||||||||
| #' If you are creating a new geom, stat, position, or scale in another package, | ||||||||
| #' you'll need to extend from `ggplot2::Geom`, `ggplot2::Stat`, | ||||||||
| #' `ggplot2::Position`, or `ggplot2::Scale`. | ||||||||
| #' | ||||||||
| #' @seealso ggproto | ||||||||
| #' @keywords internal | ||||||||
| #' @name ggplot2-ggproto | ||||||||
| NULL | ||||||||
| # More performant data.frame constructors | ||||||||
| new_data_frame <- function(..., .check = FALSE) { | ||||||||
| data <- list(...) | ||||||||
| list_2_df(data, .check) | ||||||||
| } | ||||||||
| list_2_df <- function(data, .check = FALSE) { | ||||||||
| if (.check) { | ||||||||
| n_row <- max(lengths(data)) | ||||||||
| for (i in seq_along(data)) { | ||||||||
| if (length(data[[i]]) != n_row) data[[i]] <- rep(data[[i]], length.out = n_row) | ||||||||
| } | ||||||||
| if (is.null(names(data))) { | ||||||||
| names(data) <- make.names(seq_along(data)) | ||||||||
| } | ||||||||
| } else { | ||||||||
| n_row <- if (length(data) == 0) 0 else length(data[[1]]) | ||||||||
| } | ||||||||
| class(data) <- 'data.frame' | ||||||||
| attr(data, 'row.names') <- c(NA_integer_, -n_row) | ||||||||
| data | ||||||||
| } | ||||||||
| mat_2_df <- function(data, .check = FALSE) { | ||||||||
| c_names <- colnames(data) | ||||||||
| data <- split(data, rep(seq_len(ncol(data))), each = nrow(data)) | ||||||||
| names(data) <- c_names | ||||||||
| list_2_df(data, .check) | ||||||||
| } | ||||||||
| # More performant modifyList | ||||||||
| modify_list <- function(old, new, keep_null = FALSE) { | ||||||||
| if (keep_null) { | ||||||||
| for (i in names(new)) { | ||||||||
| old[i] <- list(new[[i]]) | ||||||||
| } | ||||||||
| } else { | ||||||||
| for (i in names(new)) { | ||||||||
| old[[i]] <- new[[i]] | ||||||||
| } | ||||||||
| } | ||||||||
| old | ||||||||
| } | ||||||||
| ggplot2/R/aes.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' @include utilities.r | ||||||||
| NULL | ||||||||
| #' Construct aesthetic mappings | ||||||||
| #' | ||||||||
| #' Aesthetic mappings describe how variables in the data are mapped to visual | ||||||||
| #' properties (aesthetics) of geoms. Aesthetic mappings can be set in | ||||||||
| #' [ggplot2()] and in individual layers. | ||||||||
| #' | ||||||||
| #' This function also standardises aesthetic names by converting `color` to `colour` | ||||||||
| #' (also in substrings, e.g. `point_color` to `point_colour`) and translating old style | ||||||||
| #' R names to ggplot names (eg. `pch` to `shape`, `cex` to `size`). | ||||||||
| #' | ||||||||
| #' @section Quasiquotation: | ||||||||
| #' | ||||||||
| #' `aes()` is a [quoting function][rlang::quotation]. This means that | ||||||||
| #' its inputs are quoted to be evaluated in the context of the | ||||||||
| #' data. This makes it easy to work with variables from the data frame | ||||||||
| #' because you can name those directly. The flip side is that you have | ||||||||
| #' to use [quasiquotation][rlang::quasiquotation] to program with | ||||||||
| #' `aes()`. See a tidy evaluation tutorial such as the [dplyr | ||||||||
| #' programming vignette](http://dplyr.tidyverse.org/articles/programming.html) | ||||||||
| #' to learn more about these techniques. | ||||||||
| #' | ||||||||
| #' @param x,y,... List of name value pairs giving aesthetics to map to | ||||||||
| #' variables. The names for x and y aesthetics are typically omitted because | ||||||||
| #' they are so common; all other aesthetics must be named. | ||||||||
| #' @seealso [vars()] for another quoting function designed for | ||||||||
| #' faceting specifications. | ||||||||
| #' @return A list with class `uneval`. Components of the list are either | ||||||||
| #' quosures or constants. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' aes(x = mpg, y = wt) | ||||||||
| #' aes(mpg, wt) | ||||||||
| #' | ||||||||
| #' # You can also map aesthetics to functions of variables | ||||||||
| #' aes(x = mpg ^ 2, y = wt / cyl) | ||||||||
| #' | ||||||||
| #' # Or to constants | ||||||||
| #' aes(x = 1, colour = "smooth") | ||||||||
| #' | ||||||||
| #' # Aesthetic names are automatically standardised | ||||||||
| #' aes(col = x) | ||||||||
| #' aes(fg = x) | ||||||||
| #' aes(color = x) | ||||||||
| #' aes(colour = x) | ||||||||
| #' | ||||||||
| #' # aes() is passed to either ggplot() or specific layer. Aesthetics supplied | ||||||||
| #' # to ggplot() are used as defaults for every layer. | ||||||||
| #' ggplot(mpg, aes(displ, hwy)) + geom_point() | ||||||||
| #' ggplot(mpg) + geom_point(aes(displ, hwy)) | ||||||||
| #' | ||||||||
| #' # Tidy evaluation ---------------------------------------------------- | ||||||||
| #' # aes() automatically quotes all its arguments, so you need to use tidy | ||||||||
| #' # evaluation to create wrappers around ggplot2 pipelines. The | ||||||||
| #' # simplest case occurs when your wrapper takes dots: | ||||||||
| #' scatter_by <- function(data, ...) { | ||||||||
| #' ggplot(data) + geom_point(aes(...)) | ||||||||
| #' } | ||||||||
| #' scatter_by(mtcars, disp, drat) | ||||||||
| #' | ||||||||
| #' # If your wrapper has a more specific interface with named arguments, | ||||||||
| #' # you need "enquote and unquote": | ||||||||
| #' scatter_by <- function(data, x, y) { | ||||||||
| #' x <- enquo(x) | ||||||||
| #' y <- enquo(y) | ||||||||
| #' | ||||||||
| #' ggplot(data) + geom_point(aes(!!x, !!y)) | ||||||||
| #' } | ||||||||
| #' scatter_by(mtcars, disp, drat) | ||||||||
| #' | ||||||||
| #' # Note that users of your wrapper can use their own functions in the | ||||||||
| #' # quoted expressions and all will resolve as it should! | ||||||||
| #' cut3 <- function(x) cut_number(x, 3) | ||||||||
| #' scatter_by(mtcars, cut3(disp), drat) | ||||||||
| aes <- function(x, y, ...) { | ||||||||
| exprs <- rlang::enquos(x = x, y = y, ...) | ||||||||
| is_missing <- vapply(exprs, rlang::quo_is_missing, logical(1)) | ||||||||
| aes <- new_aes(exprs[!is_missing], env = parent.frame()) | ||||||||
| rename_aes(aes) | ||||||||
| } | ||||||||
| # Wrap symbolic objects in quosures but pull out constants out of | ||||||||
| # quosures for backward-compatibility | ||||||||
| new_aesthetic <- function(x, env = globalenv()) { | ||||||||
| if (rlang::is_quosure(x)) { | ||||||||
| if (!rlang::quo_is_symbolic(x)) { | ||||||||
| x <- rlang::quo_get_expr(x) | ||||||||
| } | ||||||||
| return(x) | ||||||||
| } | ||||||||
| if (rlang::is_symbolic(x)) { | ||||||||
| x <- rlang::new_quosure(x, env = env) | ||||||||
| return(x) | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| new_aes <- function(x, env = globalenv()) { | ||||||||
| stopifnot(is.list(x)) | ||||||||
| x <- lapply(x, new_aesthetic, env = env) | ||||||||
| structure(x, class = "uneval") | ||||||||
| } | ||||||||
| #' @export | ||||||||
| print.uneval <- function(x, ...) { | ||||||||
| cat("Aesthetic mapping: \n") | ||||||||
| if (length(x) == 0) { | ||||||||
| cat("<empty>\n") | ||||||||
| } else { | ||||||||
| values <- vapply(x, rlang::quo_label, character(1)) | ||||||||
| bullets <- paste0("* ", format(paste0("`", names(x), "`")), " -> ", values, "\n") | ||||||||
| cat(bullets, sep = "") | ||||||||
| } | ||||||||
| invisible(x) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| "[.uneval" <- function(x, i, ...) { | ||||||||
| new_aes(NextMethod()) | ||||||||
| } | ||||||||
| # If necessary coerce replacements to quosures for compatibility | ||||||||
| #' @export | ||||||||
| "[[<-.uneval" <- function(x, i, value) { | ||||||||
| new_aes(NextMethod()) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| "$<-.uneval" <- function(x, i, value) { | ||||||||
| # Can't use NextMethod() because of a bug in R 3.1 | ||||||||
| x <- unclass(x) | ||||||||
| x[[i]] <- value | ||||||||
| new_aes(x) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| "[<-.uneval" <- function(x, i, value) { | ||||||||
| new_aes(NextMethod()) | ||||||||
| } | ||||||||
| #' Standardise aesthetic names | ||||||||
| #' | ||||||||
| #' This function standardises aesthetic names by converting `color` to `colour` | ||||||||
| #' (also in substrings, e.g. `point_color` to `point_colour`) and translating old style | ||||||||
| #' R names to ggplot names (eg. `pch` to `shape`, `cex` to `size`). | ||||||||
| #' @param x Character vector of aesthetics names, such as `c("colour", "size", "shape")`. | ||||||||
| #' @return Character vector of standardised names. | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| standardise_aes_names <- function(x) { | ||||||||
| # convert US to UK spelling of colour | ||||||||
| x <- sub("color", "colour", x, fixed = TRUE) | ||||||||
| # convert old-style aesthetics names to ggplot version | ||||||||
| plyr::revalue(x, ggplot_global$base_to_ggplot, warn_missing = FALSE) | ||||||||
| } | ||||||||
| # x is a list of aesthetic mappings, as generated by aes() | ||||||||
| rename_aes <- function(x) { | ||||||||
| names(x) <- standardise_aes_names(names(x)) | ||||||||
| duplicated_names <- names(x)[duplicated(names(x))] | ||||||||
| if (length(duplicated_names) > 0L) { | ||||||||
| duplicated_message <- paste0(unique(duplicated_names), collapse = ", ") | ||||||||
| warning( | ||||||||
| "Duplicated aesthetics after name standardisation: ", duplicated_message, call. = FALSE | ||||||||
| ) | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| # Look up the scale that should be used for a given aesthetic | ||||||||
| aes_to_scale <- function(var) { | ||||||||
| var[var %in% c("x", "xmin", "xmax", "xend", "xintercept")] <- "x" | ||||||||
| var[var %in% c("y", "ymin", "ymax", "yend", "yintercept")] <- "y" | ||||||||
| var | ||||||||
| } | ||||||||
| # Figure out if an aesthetic is a position aesthetic or not | ||||||||
| is_position_aes <- function(vars) { | ||||||||
| aes_to_scale(vars) %in% c("x", "y") | ||||||||
| } | ||||||||
| #' Define aesthetic mappings programmatically | ||||||||
| #' | ||||||||
| #' Aesthetic mappings describe how variables in the data are mapped to visual | ||||||||
| #' properties (aesthetics) of geoms. [aes()] uses non-standard | ||||||||
| #' evaluation to capture the variable names. `aes_` and `aes_string` | ||||||||
| #' require you to explicitly quote the inputs either with `""` for | ||||||||
| #' `aes_string()`, or with `quote` or `~` for `aes_()`. | ||||||||
| #' (`aes_q` is an alias to `aes_`). This makes `aes_` and | ||||||||
| #' `aes_string` easy to program with. | ||||||||
| #' | ||||||||
| #' `aes_string` and `aes_` are particularly useful when writing | ||||||||
| #' functions that create plots because you can use strings or quoted | ||||||||
| #' names/calls to define the aesthetic mappings, rather than having to use | ||||||||
| #' [substitute()] to generate a call to `aes()`. | ||||||||
| #' | ||||||||
| #' I recommend using `aes_()`, because creating the equivalents of | ||||||||
| #' `aes(colour = "my colour")` or \code{aes{x = `X$1`}} | ||||||||
| #' with `aes_string()` is quite clunky. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @section Life cycle: | ||||||||
| #' | ||||||||
| #' All these functions are soft-deprecated. Please use tidy evaluation | ||||||||
| #' idioms instead (see the quasiquotation section in | ||||||||
| #' [aes()] documentation). | ||||||||
| #' | ||||||||
| #' @param x,y,... List of name value pairs. Elements must be either | ||||||||
| #' quoted calls, strings, one-sided formulas or constants. | ||||||||
| #' @seealso [aes()] | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # Three ways of generating the same aesthetics | ||||||||
| #' aes(mpg, wt, col = cyl) | ||||||||
| #' aes_(quote(mpg), quote(wt), col = quote(cyl)) | ||||||||
| #' aes_(~mpg, ~wt, col = ~cyl) | ||||||||
| #' aes_string("mpg", "wt", col = "cyl") | ||||||||
| #' | ||||||||
| #' # You can't easily mimic these calls with aes_string | ||||||||
| #' aes(`$100`, colour = "smooth") | ||||||||
| #' aes_(~ `$100`, colour = "smooth") | ||||||||
| #' # Ok, you can, but it requires a _lot_ of quotes | ||||||||
| #' aes_string("`$100`", colour = '"smooth"') | ||||||||
| #' | ||||||||
| #' # Convert strings to names with as.name | ||||||||
| #' var <- "cyl" | ||||||||
| #' aes(col = x) | ||||||||
| #' aes_(col = as.name(var)) | ||||||||
| aes_ <- function(x, y, ...) { | ||||||||
| mapping <- list(...) | ||||||||
| if (!missing(x)) mapping["x"] <- list(x) | ||||||||
| if (!missing(y)) mapping["y"] <- list(y) | ||||||||
| caller_env <- parent.frame() | ||||||||
| as_quosure_aes <- function(x) { | ||||||||
| if (is.formula(x) && length(x) == 2) { | ||||||||
| rlang::as_quosure(x) | ||||||||
| } else if (is.call(x) || is.name(x) || is.atomic(x)) { | ||||||||
| new_aesthetic(x, caller_env) | ||||||||
| } else { | ||||||||
| stop("Aesthetic must be a one-sided formula, call, name, or constant.", | ||||||||
| call. = FALSE) | ||||||||
| } | ||||||||
| } | ||||||||
| mapping <- lapply(mapping, as_quosure_aes) | ||||||||
| structure(rename_aes(mapping), class = "uneval") | ||||||||
| } | ||||||||
| #' @rdname aes_ | ||||||||
| #' @export | ||||||||
| aes_string <- function(x, y, ...) { | ||||||||
| mapping <- list(...) | ||||||||
| if (!missing(x)) mapping["x"] <- list(x) | ||||||||
| if (!missing(y)) mapping["y"] <- list(y) | ||||||||
| caller_env <- parent.frame() | ||||||||
| mapping <- lapply(mapping, function(x) { | ||||||||
| if (is.character(x)) { | ||||||||
| x <- rlang::parse_expr(x) | ||||||||
| } | ||||||||
| new_aesthetic(x, env = caller_env) | ||||||||
| }) | ||||||||
| structure(rename_aes(mapping), class = "uneval") | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname aes_ | ||||||||
| aes_q <- aes_ | ||||||||
| #' Given a character vector, create a set of identity mappings | ||||||||
| #' | ||||||||
| #' @param vars vector of variable names | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' aes_all(names(mtcars)) | ||||||||
| #' aes_all(c("x", "y", "col", "pch")) | ||||||||
| aes_all <- function(vars) { | ||||||||
| names(vars) <- vars | ||||||||
| vars <- rename_aes(vars) | ||||||||
| # Quosure the symbols in the empty environment because they can only | ||||||||
| # refer to the data mask | ||||||||
| structure( | ||||||||
| lapply(vars, function(x) rlang::new_quosure(as.name(x), emptyenv())), | ||||||||
| class = "uneval" | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Automatic aesthetic mapping | ||||||||
| #' | ||||||||
| #' @param data data.frame or names of variables | ||||||||
| #' @param ... aesthetics that need to be explicitly mapped. | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| aes_auto <- function(data = NULL, ...) { | ||||||||
| warning("aes_auto() is deprecated", call. = FALSE) | ||||||||
| # detect names of data | ||||||||
| if (is.null(data)) { | ||||||||
| stop("aes_auto requires data.frame or names of data.frame.") | ||||||||
| } else if (is.data.frame(data)) { | ||||||||
| vars <- names(data) | ||||||||
| } else { | ||||||||
| vars <- data | ||||||||
| } | ||||||||
| # automatically detected aes | ||||||||
| vars <- intersect(ggplot_global$all_aesthetics, vars) | ||||||||
| names(vars) <- vars | ||||||||
| aes <- lapply(vars, function(x) parse(text = x)[[1]]) | ||||||||
| # explicitly defined aes | ||||||||
| if (length(match.call()) > 2) { | ||||||||
| args <- as.list(match.call()[-1]) | ||||||||
| aes <- c(aes, args[names(args) != "data"]) | ||||||||
| } | ||||||||
| structure(rename_aes(aes), class = "uneval") | ||||||||
| } | ||||||||
| mapped_aesthetics <- function(x) { | ||||||||
| if (is.null(x)) { | ||||||||
| return(NULL) | ||||||||
| } | ||||||||
| is_null <- vapply(x, is.null, logical(1)) | ||||||||
| names(x)[!is_null] | ||||||||
| } | ||||||||
The use of an empty ggplot2 ensures that the profile is based on real-life use and includes complex gtable assembly. Profiles for old version are kept for reference and can be accessed at the github repository. Care should be taken in not comparing profiles across versions, as changes to code outside of gtable can have profound effect on the results. Thus, the intend of profiling is to identify bottlenecks in the implementation that are ripe for improvement, more then to quantify improvements to performance over time.
Performance focused changes across versions
To keep track of changes focused on improving the performance of gtable they are summarised below:
v0.2.0.9000
Profiling results from gtable v0.2.0 identified a range of areas that could be easily improved by fairly small code changes. These changes resulted in roughly 20% decrease in running time on the profiling code in general, while gtable related functions were between 50 and 80% decrease in running time specifically.
-
data.frameconstruction and indexing. gtable now includes a minimal constructor that makes no input checking used for working with the layout data frame. Further, indexing into the layout data frame has been improved by either treating as a list internally or directly calling.subset2 -
Input validation.
stopifnot()was identified as a bottleneck and has removed in favor of a standardif (...) stop() -
Dimension querying. The use of
nrow()andncol()has internally been substituted for direct calls tolength()of theheightsandwidthsunit vectors