Profiling Performance
Thomas Lin Pedersen
Source:../../../data/GHE/mpn/deployment/deployments/2021-03-05/vignettes/profiling.Rmd
profiling.RmdIn order to continuously monitor the performance of ggplot2 the following piece of code is used to generate a profile and inspect it:
library(ggplot2)
library(profvis)
p <- ggplot(mtcars, aes(x = mpg, y = disp)) +
geom_point() +
facet_grid(gear ~ cyl)
profile <- profvis(for (i in seq_len(100)) ggplotGrob(p))
profileFlame Graph
Data
| profvis/R/profvis.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Profile an R expression and visualize profiling data | ||||||||
| #' | ||||||||
| #' This function will run an R expression with profiling, and then return an | ||||||||
| #' htmlwidget for interactively exploring the profiling data. | ||||||||
| #' | ||||||||
| #' An alternate way to use \code{profvis} is to separately capture the profiling | ||||||||
| #' data to a file using \code{\link{Rprof}()}, and then pass the path to the | ||||||||
| #' corresponding data file as the \code{prof_input} argument to | ||||||||
| #' \code{profvis()}. | ||||||||
| #' | ||||||||
| #' @param expr Code to profile. Not compatible with \code{prof_input}. | ||||||||
| #' @param interval Interval for profiling samples, in seconds. Values less than | ||||||||
| #' 0.005 (5 ms) will probably not result in accurate timings | ||||||||
| #' @param prof_output Name of an Rprof output file or directory in which to save | ||||||||
| #' profiling data. If \code{NULL} (the default), a temporary file will be used | ||||||||
| #' and automatically removed when the function exits. For a directory, a | ||||||||
| #' random filename is used. | ||||||||
| #' | ||||||||
| #' @param prof_input The path to an \code{\link{Rprof}} data file. Not | ||||||||
| #' compatible with \code{expr} or \code{prof_output}. | ||||||||
| #' @param width Width of the htmlwidget. | ||||||||
| #' @param height Height of the htmlwidget | ||||||||
| #' @param split Direction of split. Either \code{"v"} (the default) for | ||||||||
| #' vertical, or \code{"h"} for horizontal. This is the orientation of the | ||||||||
| #' split bar. | ||||||||
| #' @param torture Triggers garbage collection after every \code{torture} memory | ||||||||
| #' allocation call. | ||||||||
| #' | ||||||||
| #' Note that memory allocation is only approximate due to the nature of the | ||||||||
| #' sampling profiler and garbage collection: when garbage collection triggers, | ||||||||
| #' memory allocations will be attributed to different lines of code. Using | ||||||||
| #' \code{torture = steps} helps prevent this, by making R trigger garbage | ||||||||
| #' collection after every \code{torture} memory allocation step. | ||||||||
| #' | ||||||||
| #' @param simplify Whether to simplify the profiles by removing | ||||||||
| #' intervening frames caused by lazy evaluation. This only has an | ||||||||
| #' effect on R 4.0. See the \code{filter.callframes} argument of | ||||||||
| #' \code{\link{Rprof}()}. | ||||||||
| #' | ||||||||
| #' @seealso \code{\link{print.profvis}} for printing options. | ||||||||
| #' @seealso \code{\link{Rprof}} for more information about how the profiling | ||||||||
| #' data is collected. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Only run these examples in interactive R sessions | ||||||||
| #' if (interactive()) { | ||||||||
| #' | ||||||||
| #' # Profile some code | ||||||||
| #' profvis({ | ||||||||
| #' dat <- data.frame( | ||||||||
| #' x = rnorm(5e4), | ||||||||
| #' y = rnorm(5e4) | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' plot(x ~ y, data = dat) | ||||||||
| #' m <- lm(x ~ y, data = dat) | ||||||||
| #' abline(m, col = "red") | ||||||||
| #' }) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' # Save a profile to an HTML file | ||||||||
| #' p <- profvis({ | ||||||||
| #' dat <- data.frame( | ||||||||
| #' x = rnorm(5e4), | ||||||||
| #' y = rnorm(5e4) | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' plot(x ~ y, data = dat) | ||||||||
| #' m <- lm(x ~ y, data = dat) | ||||||||
| #' abline(m, col = "red") | ||||||||
| #' }) | ||||||||
| #' htmlwidgets::saveWidget(p, "profile.html") | ||||||||
| #' | ||||||||
| #' # Can open in browser from R | ||||||||
| #' browseURL("profile.html") | ||||||||
| #' | ||||||||
| #' } | ||||||||
| #' @import htmlwidgets | ||||||||
| #' @importFrom utils Rprof | ||||||||
| #' @export | ||||||||
| profvis <- function(expr = NULL, interval = 0.01, prof_output = NULL, | ||||||||
| prof_input = NULL, width = NULL, height = NULL, | ||||||||
| split = c("h", "v"), torture = 0, simplify = TRUE) | ||||||||
| { | ||||||||
| split <- match.arg(split) | ||||||||
| expr_q <- substitute(expr) | ||||||||
| if (is.null(prof_input) && is.null(expr_q)) { | ||||||||
| stop("profvis must be called with `expr` or `prof_input` ") | ||||||||
| } | ||||||||
| if (!is.null(prof_input) && (!is.null(expr_q) && !is.null(prof_output))) { | ||||||||
| stop("The `prof_input` argument cannot be used with `expr` or `prof_output`.") | ||||||||
| } | ||||||||
| if (interval < 0.005) { | ||||||||
| message("Intervals smaller than ~5ms will probably not result in accurate timings.") | ||||||||
| } | ||||||||
| if (!is.null(expr_q)) { | ||||||||
| # Change the srcfile to add "<expr>" as the filename. Code executed from the | ||||||||
| # console will have "" here, and code executed in a knitr code block will | ||||||||
| # have "<text>". This value is used by the profiler as the filename listed | ||||||||
| # in the profiler output. We need to do this to distinguish code that was | ||||||||
| # run in the profvis({}) code block from code that was run outside of it. | ||||||||
| # See https://github.com/rstudio/profvis/issues/57 | ||||||||
| attr(expr_q, "srcfile")$filename <- "<expr>" | ||||||||
| # Keep original expression source code | ||||||||
| expr_source <- attr(expr_q, "wholeSrcref", exact = TRUE) | ||||||||
| expr_source <- attr(expr_source, "srcfile", exact = TRUE)$lines | ||||||||
| # Usually, $lines is a single string, but sometimes it can be split up into a | ||||||||
| # vector. Make sure it's a single string. | ||||||||
| expr_source <- paste(expr_source, collapse = "\n") | ||||||||
| prof_extension <- getOption("profvis.prof_extension", default = ".prof") | ||||||||
| if (is.null(prof_output) && !is.null(getOption("profvis.prof_output"))) | ||||||||
| prof_output <- getOption("profvis.prof_output") | ||||||||
| remove_on_exit <- FALSE | ||||||||
| if (is.null(prof_output)) { | ||||||||
| prof_output <- tempfile(fileext = prof_extension) | ||||||||
| remove_on_exit <- TRUE | ||||||||
| } | ||||||||
| else { | ||||||||
| if (dir.exists(prof_output)) | ||||||||
| prof_output <- tempfile(fileext = prof_extension, tmpdir = prof_output) | ||||||||
| } | ||||||||
| gc() | ||||||||
| if (!identical(torture, 0)) { | ||||||||
| gctorture2(step = torture) | ||||||||
| on.exit(gctorture2(step = 0), add = TRUE) | ||||||||
| } | ||||||||
| if (getRversion() >= "4.0.0") { | ||||||||
| Rprof(prof_output, interval = interval, line.profiling = TRUE, | ||||||||
| gc.profiling = TRUE, memory.profiling = TRUE, | ||||||||
| filter.callframes = simplify) | ||||||||
| } else { | ||||||||
| Rprof(prof_output, interval = interval, line.profiling = TRUE, | ||||||||
| gc.profiling = TRUE, memory.profiling = TRUE) | ||||||||
| } | ||||||||
| on.exit(Rprof(NULL), add = TRUE) | ||||||||
| if (remove_on_exit) | ||||||||
| on.exit(unlink(prof_output), add = TRUE) | ||||||||
| tryCatch( | ||||||||
| force(expr), | ||||||||
| error = function(e) { | ||||||||
| message("profvis: code exited with error:\n", e$message, "\n") | ||||||||
| }, | ||||||||
| interrupt = function(e) { | ||||||||
| message("profvis: interrupt received.") | ||||||||
| } | ||||||||
| ) | ||||||||
| Rprof(NULL) | ||||||||
| } else { | ||||||||
| # If we got here, we were provided a prof_input file instead of expr | ||||||||
| expr_source <- NULL | ||||||||
| prof_output <- prof_input | ||||||||
| } | ||||||||
| message <- parse_rprof(prof_output, expr_source) | ||||||||
| message$prof_output <- prof_output | ||||||||
| # Patterns to highlight on flamegraph | ||||||||
| message$highlight <- highlightPatterns() | ||||||||
| message$split <- split | ||||||||
| htmlwidgets::createWidget( | ||||||||
| name = 'profvis', | ||||||||
| list(message = message), | ||||||||
| width = width, | ||||||||
| height = height, | ||||||||
| package = 'profvis', | ||||||||
| sizingPolicy = htmlwidgets::sizingPolicy( | ||||||||
| padding = 0, | ||||||||
| browser.fill = TRUE, | ||||||||
| viewer.suppress = TRUE, | ||||||||
| knitr.defaultWidth = "100%", | ||||||||
| knitr.defaultHeight = "600px", | ||||||||
| knitr.figure = FALSE | ||||||||
| ) | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Print a profvis object | ||||||||
| #' | ||||||||
| #' @inheritParams profvis | ||||||||
| #' @param x The object to print. | ||||||||
| #' @param ... Further arguments to passed on to other print methods. | ||||||||
| #' @export | ||||||||
| print.profvis <- function(x, ..., width = NULL, height = NULL, split = NULL) { | ||||||||
| if (!is.null(split)) { | ||||||||
| split <- match.arg(split, c("h", "v")) | ||||||||
| x$x$message$split <- split | ||||||||
| } | ||||||||
| if (!is.null(width)) x$width <- width | ||||||||
| if (!is.null(height)) x$height <- height | ||||||||
| f <- getOption("profvis.print") | ||||||||
| if (is.function(f)) { | ||||||||
| f(x, ...) | ||||||||
| } else { | ||||||||
| NextMethod() | ||||||||
| } | ||||||||
| } | ||||||||
| #' Widget output function for use in Shiny | ||||||||
| #' | ||||||||
| #' @param outputId Output variable for profile visualization. | ||||||||
| #' | ||||||||
| #' @inheritParams profvis | ||||||||
| #' @export | ||||||||
| profvisOutput <- function(outputId, width = '100%', height = '600px'){ | ||||||||
| shinyWidgetOutput(outputId, 'profvis', width, height, package = 'profvis') | ||||||||
| } | ||||||||
| #' Widget render function for use in Shiny | ||||||||
| #' | ||||||||
| #' @param expr An expression that returns a profvis object. | ||||||||
| #' @param env The environment in which to evaluate \code{expr}. | ||||||||
| #' @param quoted Is \code{expr} a quoted expression (with \code{\link{quote}()})? | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| renderProfvis <- function(expr, env = parent.frame(), quoted = FALSE) { | ||||||||
| if (!quoted) { expr <- substitute(expr) } # force quoted | ||||||||
| shinyRenderWidget(expr, profvisOutput, env, quoted = TRUE) | ||||||||
| } | ||||||||
| evaluate/R/eval.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Evaluate input and return all details of evaluation. | ||||||||
| #' | ||||||||
| #' Compare to [eval()], `evaluate` captures all of the | ||||||||
| #' information necessary to recreate the output as if you had copied and pasted | ||||||||
| #' the code into a R terminal. It captures messages, warnings, errors and | ||||||||
| #' output, all correctly interleaved in the order in which they occured. It | ||||||||
| #' stores the final result, whether or not it should be visible, and the | ||||||||
| #' contents of the current graphics device. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @param input input object to be parsed and evaluated. May be a string, file | ||||||||
| #' connection or function. Passed on to [parse_all()]. | ||||||||
| #' @param envir environment in which to evaluate expressions. | ||||||||
| #' @param enclos when `envir` is a list or data frame, this is treated as | ||||||||
| #' the parent environment to `envir`. | ||||||||
| #' @param debug if `TRUE`, displays information useful for debugging, | ||||||||
| #' including all output that evaluate captures. | ||||||||
| #' @param stop_on_error if `2`, evaluation will halt on first error and you | ||||||||
| #' will get no results back. If `1`, evaluation will stop on first error | ||||||||
| #' without signaling the error, and you will get back all results up to that | ||||||||
| #' point. If `0` will continue running all code, just as if you'd pasted | ||||||||
| #' the code into the command line. | ||||||||
| #' @param keep_warning,keep_message whether to record warnings and messages. | ||||||||
| #' @param new_device if `TRUE`, will open a new graphics device and | ||||||||
| #' automatically close it after completion. This prevents evaluation from | ||||||||
| #' interfering with your existing graphics environment. | ||||||||
| #' @param output_handler an instance of [output_handler()] that | ||||||||
| #' processes the output from the evaluation. The default simply prints the | ||||||||
| #' visible return values. | ||||||||
| #' @param filename string overrriding the [base::srcfile()] filename. | ||||||||
| #' @param include_timing if `TRUE`, evaluate will wrap each input | ||||||||
| #' expression in `system.time()`, which will be accessed by following | ||||||||
| #' `replay()` call to produce timing information for each evaluated | ||||||||
| #' command. | ||||||||
| #' @import graphics grDevices utils | ||||||||
| evaluate <- function(input, envir = parent.frame(), enclos = NULL, debug = FALSE, | ||||||||
| stop_on_error = 0L, keep_warning = TRUE, keep_message = TRUE, | ||||||||
| new_device = TRUE, output_handler = default_output_handler, | ||||||||
| filename = NULL, include_timing = FALSE) { | ||||||||
| stop_on_error <- as.integer(stop_on_error) | ||||||||
| stopifnot(length(stop_on_error) == 1) | ||||||||
| parsed <- parse_all(input, filename, stop_on_error != 2L) | ||||||||
| if (inherits(err <- attr(parsed, 'PARSE_ERROR'), 'error')) { | ||||||||
| source <- new_source(parsed$src) | ||||||||
| output_handler$source(source) | ||||||||
| output_handler$error(err) | ||||||||
| err$call <- NULL # the call is unlikely to be useful | ||||||||
| return(list(source, err)) | ||||||||
| } | ||||||||
| if (is.null(enclos)) { | ||||||||
| enclos <- if (is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv() | ||||||||
| } | ||||||||
| if (new_device) { | ||||||||
| # Start new graphics device and clean up afterwards | ||||||||
| if (identical(grDevices::pdf, getOption("device"))) { | ||||||||
| dev.new(file = NULL) | ||||||||
| } else dev.new() | ||||||||
| dev.control(displaylist = "enable") | ||||||||
| dev <- dev.cur() | ||||||||
| on.exit(dev.off(dev)) | ||||||||
| } | ||||||||
| # clean up the last_plot object after an evaluate() call (cf yihui/knitr#722) | ||||||||
| on.exit(assign("last_plot", NULL, envir = environment(plot_snapshot)), add = TRUE) | ||||||||
| out <- vector("list", nrow(parsed)) | ||||||||
| for (i in seq_along(out)) { | ||||||||
| expr <- parsed$expr[[i]] | ||||||||
| if (!is.null(expr)) | ||||||||
| expr <- as.expression(expr) | ||||||||
| out[[i]] <- evaluate_call( | ||||||||
| expr, parsed$src[[i]], | ||||||||
| envir = envir, enclos = enclos, debug = debug, last = i == length(out), | ||||||||
| use_try = stop_on_error != 2L, | ||||||||
| keep_warning = keep_warning, keep_message = keep_message, | ||||||||
| output_handler = output_handler, | ||||||||
| include_timing = include_timing) | ||||||||
| if (stop_on_error > 0L) { | ||||||||
| errs <- vapply(out[[i]], is.error, logical(1)) | ||||||||
| if (!any(errs)) next | ||||||||
| if (stop_on_error == 1L) break | ||||||||
| } | ||||||||
| } | ||||||||
| unlist(out, recursive = FALSE, use.names = FALSE) | ||||||||
| } | ||||||||
| evaluate_call <- function(call, src = NULL, | ||||||||
| envir = parent.frame(), enclos = NULL, | ||||||||
| debug = FALSE, last = FALSE, use_try = FALSE, | ||||||||
| keep_warning = TRUE, keep_message = TRUE, | ||||||||
| output_handler = new_output_handler(), include_timing = FALSE) { | ||||||||
| if (debug) message(src) | ||||||||
| if (is.null(call) && !last) { | ||||||||
| source <- new_source(src) | ||||||||
| output_handler$source(source) | ||||||||
| return(list(source)) | ||||||||
| } | ||||||||
| stopifnot(is.call(call) || is.language(call) || is.atomic(call)) | ||||||||
| # Capture output | ||||||||
| w <- watchout(debug) | ||||||||
| on.exit(w$close()) | ||||||||
| # Capture error output from try() (#88) | ||||||||
| old_try_outfile <- options(try.outFile = w$get_con()) | ||||||||
| on.exit(options(old_try_outfile), add = TRUE) | ||||||||
| source <- new_source(src) | ||||||||
| output_handler$source(source) | ||||||||
| output <- list(source) | ||||||||
| dev <- dev.cur() | ||||||||
| handle_output <- function(plot = FALSE, incomplete_plots = FALSE) { | ||||||||
| # if dev.cur() has changed, we should not record plots any more | ||||||||
| plot <- plot && identical(dev, dev.cur()) | ||||||||
| out <- w$get_new(plot, incomplete_plots, | ||||||||
| output_handler$text, output_handler$graphics) | ||||||||
| output <<- c(output, out) | ||||||||
| } | ||||||||
| flush_old <- .env$flush_console; on.exit({ | ||||||||
| .env$flush_console <- flush_old | ||||||||
| }, add = TRUE) | ||||||||
| .env$flush_console <- function() handle_output(FALSE) | ||||||||
| # Hooks to capture plot creation | ||||||||
| capture_plot <- function() { | ||||||||
| handle_output(TRUE) | ||||||||
| } | ||||||||
| hook_list <- list( | ||||||||
| persp = capture_plot, | ||||||||
| before.plot.new = capture_plot, | ||||||||
| before.grid.newpage = capture_plot | ||||||||
| ) | ||||||||
| set_hooks(hook_list) | ||||||||
| on.exit(remove_hooks(hook_list), add = TRUE) | ||||||||
| handle_condition <- function(cond) { | ||||||||
| handle_output() | ||||||||
| output <<- c(output, list(cond)) | ||||||||
| } | ||||||||
| # Handlers for warnings, errors and messages | ||||||||
| wHandler <- if (keep_warning) function(wn) { | ||||||||
| # do not handle the warning as it will be raised as error after | ||||||||
| if (getOption("warn") >= 2) return() | ||||||||
| if (getOption("warn") >= 0) { | ||||||||
| handle_condition(wn) | ||||||||
| output_handler$warning(wn) | ||||||||
| } | ||||||||
| invokeRestart("muffleWarning") | ||||||||
| } else identity | ||||||||
| eHandler <- if (use_try) function(e) { | ||||||||
| handle_condition(e) | ||||||||
| output_handler$error(e) | ||||||||
| } else identity | ||||||||
| mHandler <- if (keep_message) function(m) { | ||||||||
| handle_condition(m) | ||||||||
| output_handler$message(m) | ||||||||
| invokeRestart("muffleMessage") | ||||||||
| } else identity | ||||||||
| ev <- list(value = NULL, visible = FALSE) | ||||||||
| if (use_try) { | ||||||||
| handle <- function(f) try(f, silent = TRUE) | ||||||||
| } else { | ||||||||
| handle <- force | ||||||||
| } | ||||||||
| value_handler <- output_handler$value | ||||||||
| if (include_timing) { | ||||||||
| timing_fn <- function(x) system.time(x)[1:3] | ||||||||
| } else { | ||||||||
| timing_fn <- function(x) {x; NULL}; | ||||||||
| } | ||||||||
| if (length(funs <- .env$inject_funs)) { | ||||||||
| funs_names <- names(funs) | ||||||||
| funs_new <- !vapply(funs_names, exists, logical(1), envir, inherits = FALSE) | ||||||||
| funs_names <- funs_names[funs_new] | ||||||||
| funs <- funs[funs_new] | ||||||||
| on.exit(rm(list = funs_names, envir = envir), add = TRUE) | ||||||||
| for (i in seq_along(funs_names)) assign(funs_names[i], funs[[i]], envir) | ||||||||
| } | ||||||||
| multi_args <- length(formals(value_handler)) > 1 | ||||||||
| for (expr in call) { | ||||||||
| srcindex <- length(output) | ||||||||
| time <- timing_fn(handle(ev <- withCallingHandlers( | ||||||||
| withVisible(eval(expr, envir, enclos)), | ||||||||
| warning = wHandler, error = eHandler, message = mHandler))) | ||||||||
| handle_output(TRUE) | ||||||||
| if (!is.null(time)) | ||||||||
| attr(output[[srcindex]]$src, 'timing') <- time | ||||||||
| # If visible or the value handler has multi args, process and capture output | ||||||||
| if (ev$visible || multi_args) { | ||||||||
| pv <- list(value = NULL, visible = FALSE) | ||||||||
| value_fun <- if (multi_args) value_handler else { | ||||||||
| function(x, visible) value_handler(x) | ||||||||
| } | ||||||||
| handle(pv <- withCallingHandlers(withVisible( | ||||||||
| value_fun(ev$value, ev$visible) | ||||||||
| ), warning = wHandler, error = eHandler, message = mHandler)) | ||||||||
| handle_output(TRUE) | ||||||||
| # If the return value is visible, save the value to the output | ||||||||
| if (pv$visible) output <- c(output, list(pv$value)) | ||||||||
| } | ||||||||
| } | ||||||||
| # Always capture last plot, even if incomplete | ||||||||
| if (last) { | ||||||||
| handle_output(TRUE, TRUE) | ||||||||
| } | ||||||||
| output | ||||||||
| } | ||||||||
| #' Inject functions into the environment of `evaluate()` | ||||||||
| #' | ||||||||
| #' Create functions in the environment specified in the `envir` argument of | ||||||||
| #' [evaluate()]. This can be helpful if you want to substitute certain | ||||||||
| #' functions when evaluating the code. To make sure it does not wipe out | ||||||||
| #' existing functions in the environment, only functions that do not exist in | ||||||||
| #' the environment are injected. | ||||||||
| #' @param ... Named arguments of functions. If empty, previously injected | ||||||||
| #' functions will be emptied. | ||||||||
| #' @note For expert use only. Do not use it unless you clearly understand it. | ||||||||
| #' @keywords internal | ||||||||
| #' @examples library(evaluate) | ||||||||
| #' # normally you cannot capture the output of system | ||||||||
| #' evaluate("system('R --version')") | ||||||||
| #' | ||||||||
| #' # replace the system() function | ||||||||
| #' inject_funs(system = function(...) cat(base::system(..., intern = TRUE), sep = '\n')) | ||||||||
| #' | ||||||||
| #' evaluate("system('R --version')") | ||||||||
| #' | ||||||||
| #' inject_funs() # empty previously injected functions | ||||||||
| #' @export | ||||||||
| inject_funs <- function(...) { | ||||||||
| funs <- list(...) | ||||||||
| funs <- funs[names(funs) != ''] | ||||||||
| .env$inject_funs <- Filter(is.function, funs) | ||||||||
| } | ||||||||
| knitr/R/hooks.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| # format a single inline object | ||||||||
| .inline.hook = function(x) { | ||||||||
| if (is.numeric(x)) x = round_digits(x) | ||||||||
| paste(as.character(x), collapse = ', ') | ||||||||
| } | ||||||||
| .out.hook = function(x, options) x | ||||||||
| .plot.hook = function(x, options) paste(x, collapse = '.') | ||||||||
| .default.hooks = list( | ||||||||
| source = .out.hook, output = .out.hook, warning = .out.hook, | ||||||||
| message = .out.hook, error = .out.hook, plot = .plot.hook, | ||||||||
| inline = .inline.hook, chunk = .out.hook, text = identity, | ||||||||
| evaluate.inline = function(code, envir = knit_global()) { | ||||||||
| v = withVisible(eval(parse_only(code), envir = envir)) | ||||||||
| if (v$visible) knit_print(v$value, inline = TRUE, options = opts_chunk$get()) | ||||||||
| }, | ||||||||
| evaluate = function(...) evaluate::evaluate(...), document = identity | ||||||||
| ) | ||||||||
| #' Hooks for R code chunks, inline R code and output | ||||||||
| #' | ||||||||
| #' A hook is a function of a pre-defined form (arguments) that takes values of | ||||||||
| #' arguments and returns desired output. The object \code{knit_hooks} is used to | ||||||||
| #' access or set hooks in this package. | ||||||||
| #' @export | ||||||||
| #' @references Usage: \url{https://yihui.org/knitr/objects/} | ||||||||
| #' | ||||||||
| #' Components in \code{knit_hooks}: \url{https://yihui.org/knitr/hooks/} | ||||||||
| #' @examples knit_hooks$get('source'); knit_hooks$get('inline') | ||||||||
| knit_hooks = new_defaults(.default.hooks) | ||||||||
| render_brew = function() NULL | ||||||||
| # the chunk option out.lines = n (first n rows), -n (last n rows), or c(n1, n2) | ||||||||
| # (first n1 and last n2 rows) | ||||||||
| hook_suppress = function(x, options) { | ||||||||
| n = options$out.lines | ||||||||
| if (length(n) == 0 || !is.numeric(n) || length(n) > 2) return(x) | ||||||||
| x = split_lines(x) | ||||||||
| m = length(x) | ||||||||
| if (length(n) == 1) { | ||||||||
| if (m > abs(n)) { | ||||||||
| x = if (n >= 0) c(head(x, n), '....') else c('....', tail(x, -n)) | ||||||||
| } | ||||||||
| } else { | ||||||||
| if (m > sum(n)) x = c(head(x, n[1]), '....', tail(x, n[2])) | ||||||||
| } | ||||||||
| one_string(x) | ||||||||
| } | ||||||||
| #' Hooks for code chunk options | ||||||||
| #' | ||||||||
| #' Like \code{\link{knit_hooks}}, this object can be used to set hook functions | ||||||||
| #' to manipulate chunk options. | ||||||||
| #' | ||||||||
| #' For every code chunk, if the chunk option named, say, \code{FOO}, is not | ||||||||
| #' \code{NULL}, and a hook function with the same name has been set via | ||||||||
| #' \code{opts_hooks$set(FOO = function(options) { options })} (you can manipuate | ||||||||
| #' the \code{options} argument in the function and return it), the hook function | ||||||||
| #' will be called to update the chunk options. | ||||||||
| #' @references \url{https://yihui.org/knitr/hooks/} | ||||||||
| #' @export | ||||||||
| #' @examples # make sure the figure width is no smaller than fig.height | ||||||||
| #' opts_hooks$set(fig.width = function(options) { | ||||||||
| #' if (options$fig.width < options$fig.height) { | ||||||||
| #' options$fig.width = options$fig.height | ||||||||
| #' } | ||||||||
| #' options | ||||||||
| #' }) | ||||||||
| #' # remove all hooks | ||||||||
| #' opts_hooks$restore() | ||||||||
| opts_hooks = new_defaults(list()) | ||||||||
| knitr/R/block.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| # S3 method to deal with chunks and inline text respectively | ||||||||
| process_group = function(x) { | ||||||||
| UseMethod('process_group', x) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| process_group.block = function(x) call_block(x) | ||||||||
| #' @export | ||||||||
| process_group.inline = function(x) { | ||||||||
| x = call_inline(x) | ||||||||
| knit_hooks$get('text')(x) | ||||||||
| } | ||||||||
| call_block = function(block) { | ||||||||
| # now try eval all options except those in eval.after and their aliases | ||||||||
| af = opts_knit$get('eval.after'); al = opts_knit$get('aliases') | ||||||||
| if (!is.null(al) && !is.null(af)) af = c(af, names(al[af %in% al])) | ||||||||
| # expand parameters defined via template | ||||||||
| if (!is.null(block$params$opts.label)) { | ||||||||
| block$params = merge_list(opts_template$get(block$params$opts.label), block$params) | ||||||||
| } | ||||||||
| params = opts_chunk$merge(block$params) | ||||||||
| opts_current$restore(params) | ||||||||
| for (o in setdiff(names(params), af)) params[o] = list(eval_lang(params[[o]])) | ||||||||
| label = ref.label = params$label | ||||||||
| if (!is.null(params$ref.label)) ref.label = sc_split(params$ref.label) | ||||||||
| params[["code"]] = params[["code"]] %n% unlist(knit_code$get(ref.label), use.names = FALSE) | ||||||||
| if (opts_knit$get('progress')) print(block) | ||||||||
| if (!is.null(params$child)) { | ||||||||
| if (!is_blank(params$code)) warning( | ||||||||
| "The chunk '", params$label, "' has the 'child' option, ", | ||||||||
| "and this code chunk must be empty. Its code will be ignored." | ||||||||
| ) | ||||||||
| if (!params$eval) return('') | ||||||||
| cmds = lapply(sc_split(params$child), knit_child, options = block$params) | ||||||||
| out = one_string(unlist(cmds)) | ||||||||
| return(out) | ||||||||
| } | ||||||||
| params$code = parse_chunk(params$code) # parse sub-chunk references | ||||||||
| ohooks = opts_hooks$get() | ||||||||
| for (opt in names(ohooks)) { | ||||||||
| hook = ohooks[[opt]] | ||||||||
| if (!is.function(hook)) { | ||||||||
| warning("The option hook '", opt, "' should be a function") | ||||||||
| next | ||||||||
| } | ||||||||
| if (!is.null(params[[opt]])) params = as.strict_list(hook(params)) | ||||||||
| if (!is.list(params)) | ||||||||
| stop("The option hook '", opt, "' should return a list of chunk options") | ||||||||
| } | ||||||||
| params = fix_options(params) # for compatibility | ||||||||
| # Check cache | ||||||||
| if (params$cache > 0) { | ||||||||
| content = c( | ||||||||
| params[if (params$cache < 3) cache1.opts else setdiff(names(params), cache0.opts)], | ||||||||
| 75L, if (params$cache == 2) params[cache2.opts] | ||||||||
| ) | ||||||||
| if (params$engine == 'R' && isFALSE(params$cache.comments)) { | ||||||||
| content[['code']] = parse_only(content[['code']]) | ||||||||
| } | ||||||||
| hash = paste(valid_path(params$cache.path, label), digest(content), sep = '_') | ||||||||
| params$hash = hash | ||||||||
| if (cache$exists(hash, params$cache.lazy) && | ||||||||
| isFALSE(params$cache.rebuild) && | ||||||||
| params$engine != 'Rcpp') { | ||||||||
| if (opts_knit$get('verbose')) message(' loading cache from ', hash) | ||||||||
| cache$load(hash, lazy = params$cache.lazy) | ||||||||
| cache_engine(params) | ||||||||
| if (!params$include) return('') | ||||||||
| if (params$cache == 3) return(cache$output(hash)) | ||||||||
| } | ||||||||
| if (params$engine == 'R') | ||||||||
| cache$library(params$cache.path, save = FALSE) # load packages | ||||||||
| } else if (label %in% names(dep_list$get()) && !isFALSE(opts_knit$get('warn.uncached.dep'))) | ||||||||
| warning2('code chunks must not depend on the uncached chunk "', label, '"') | ||||||||
| params$params.src = block$params.src | ||||||||
| opts_current$restore(params) # save current options | ||||||||
| # set local options() for the current R chunk | ||||||||
| if (is.list(params$R.options)) { | ||||||||
| op = options(params$R.options); on.exit(options(op), add = TRUE) | ||||||||
| } | ||||||||
| block_exec(params) | ||||||||
| } | ||||||||
| # options that should affect cache when cache level = 1,2 | ||||||||
| cache1.opts = c('code', 'eval', 'cache', 'cache.path', 'message', 'warning', 'error') | ||||||||
| # more options affecting cache level 2 | ||||||||
| cache2.opts = c('fig.keep', 'fig.path', 'fig.ext', 'dev', 'dpi', 'dev.args', 'fig.width', 'fig.height') | ||||||||
| # options that should not affect cache | ||||||||
| cache0.opts = c('include', 'out.width.px', 'out.height.px', 'cache.rebuild') | ||||||||
| block_exec = function(options) { | ||||||||
| # when code is not R language | ||||||||
| if (options$engine != 'R') { | ||||||||
| res.before = run_hooks(before = TRUE, options) | ||||||||
| engine = get_engine(options$engine) | ||||||||
| output = in_dir(input_dir(), engine(options)) | ||||||||
| if (is.list(output)) output = unlist(output) | ||||||||
| res.after = run_hooks(before = FALSE, options) | ||||||||
| output = paste(c(res.before, output, res.after), collapse = '') | ||||||||
| output = knit_hooks$get('chunk')(output, options) | ||||||||
| if (options$cache) { | ||||||||
| cache.exists = cache$exists(options$hash, options$cache.lazy) | ||||||||
| if (options$cache.rebuild || !cache.exists) block_cache(options, output, switch( | ||||||||
| options$engine, | ||||||||
| 'stan' = options$output.var, 'sql' = options$output.var, character(0) | ||||||||
| )) | ||||||||
| } | ||||||||
| return(if (options$include) output else '') | ||||||||
| } | ||||||||
| # eval chunks (in an empty envir if cache) | ||||||||
| env = knit_global() | ||||||||
| obj.before = ls(globalenv(), all.names = TRUE) # global objects before chunk | ||||||||
| keep = options$fig.keep | ||||||||
| keep.idx = NULL | ||||||||
| if (is.logical(keep)) keep = which(keep) | ||||||||
| if (is.numeric(keep)) { | ||||||||
| keep.idx = keep | ||||||||
| keep = "index" | ||||||||
| } | ||||||||
| if (keep.pars <- opts_knit$get('global.par')) on.exit({ | ||||||||
| opts_knit$set(global.pars = par(no.readonly = TRUE)) | ||||||||
| }, add = TRUE) | ||||||||
| tmp.fig = tempfile(); on.exit(unlink(tmp.fig), add = TRUE) | ||||||||
| # open a device to record plots if not using a global device or no device is | ||||||||
| # open, and close this device if we don't want to use a global device | ||||||||
| if (!opts_knit$get('global.device') || is.null(dev.list())) { | ||||||||
| chunk_device(options, keep != 'none', tmp.fig) | ||||||||
| dv = dev.cur() | ||||||||
| if (!opts_knit$get('global.device')) on.exit(dev.off(dv), add = TRUE) | ||||||||
| showtext(options) # showtext support | ||||||||
| } | ||||||||
| # preserve par() settings from the last code chunk | ||||||||
| if (keep.pars) par2(opts_knit$get('global.pars')) | ||||||||
| res.before = run_hooks(before = TRUE, options, env) # run 'before' hooks | ||||||||
| code = options$code | ||||||||
| echo = options$echo # tidy code if echo | ||||||||
| if (!isFALSE(echo) && !isFALSE(options$tidy) && length(code)) { | ||||||||
| tidy.method = if (isTRUE(options$tidy)) 'formatR' else options$tidy | ||||||||
| if (is.character(tidy.method)) tidy.method = switch( | ||||||||
| tidy.method, | ||||||||
| formatR = function(code, ...) formatR::tidy_source(text = code, output = FALSE, ...)$text.tidy, | ||||||||
| styler = function(code, ...) unclass(styler::style_text(text = code, ...)) | ||||||||
| ) | ||||||||
| res = try_silent(do.call(tidy.method, c(list(code), options$tidy.opts))) | ||||||||
| if (!inherits(res, 'try-error')) code = res else warning( | ||||||||
| "Failed to tidy R code in chunk '", options$label, "'. Reason:\n", res | ||||||||
| ) | ||||||||
| } | ||||||||
| # only evaluate certain lines | ||||||||
| if (is.numeric(ev <- options$eval)) { | ||||||||
| # group source code into syntactically complete expressions | ||||||||
| if (isFALSE(options$tidy)) code = sapply(xfun::split_source(code), one_string) | ||||||||
| iss = seq_along(code) | ||||||||
| code = comment_out(code, '##', setdiff(iss, iss[ev]), newline = FALSE) | ||||||||
| } | ||||||||
| # guess plot file type if it is NULL | ||||||||
| if (keep != 'none' && is.null(options$fig.ext)) | ||||||||
| options$fig.ext = dev2ext(options$dev) | ||||||||
| cache.exists = cache$exists(options$hash, options$cache.lazy) | ||||||||
| evaluate = knit_hooks$get('evaluate') | ||||||||
| # return code with class 'source' if not eval chunks | ||||||||
| res = if (is_blank(code)) list() else if (isFALSE(ev)) { | ||||||||
| as.source(code) | ||||||||
| } else if (cache.exists && isFALSE(options$cache.rebuild)) { | ||||||||
| fix_evaluate(cache$output(options$hash, 'list'), options$cache == 1) | ||||||||
| } else in_dir( | ||||||||
| input_dir(), | ||||||||
| evaluate( | ||||||||
| code, envir = env, new_device = FALSE, | ||||||||
| keep_warning = !isFALSE(options$warning), | ||||||||
| keep_message = !isFALSE(options$message), | ||||||||
| stop_on_error = if (options$error && options$include) 0L else 2L, | ||||||||
| output_handler = knit_handlers(options$render, options) | ||||||||
| ) | ||||||||
| ) | ||||||||
| if (options$cache %in% 1:2 && (!cache.exists || isTRUE(options$cache.rebuild))) { | ||||||||
| # make a copy for cache=1,2; when cache=2, we do not really need plots | ||||||||
| res.orig = if (options$cache == 2) remove_plot(res, keep == 'high') else res | ||||||||
| } | ||||||||
| # eval other options after the chunk | ||||||||
| if (!isFALSE(ev)) | ||||||||
| for (o in opts_knit$get('eval.after')) | ||||||||
| options[o] = list(eval_lang(options[[o]], env)) | ||||||||
| # remove some components according options | ||||||||
| if (isFALSE(echo)) { | ||||||||
| res = Filter(Negate(evaluate::is.source), res) | ||||||||
| } else if (is.numeric(echo)) { | ||||||||
| # choose expressions to echo using a numeric vector | ||||||||
| res = if (isFALSE(ev)) { | ||||||||
| as.source(code[echo]) | ||||||||
| } else { | ||||||||
| filter_evaluate(res, echo, evaluate::is.source) | ||||||||
| } | ||||||||
| } | ||||||||
| if (options$results == 'hide') res = Filter(Negate(is.character), res) | ||||||||
| if (options$results == 'hold') { | ||||||||
| i = vapply(res, is.character, logical(1)) | ||||||||
| if (any(i)) res = c(res[!i], merge_character(res[i])) | ||||||||
| } | ||||||||
| res = filter_evaluate(res, options$warning, evaluate::is.warning) | ||||||||
| res = filter_evaluate(res, options$message, evaluate::is.message) | ||||||||
| # rearrange locations of figures | ||||||||
| figs = find_recordedplot(res) | ||||||||
| if (length(figs) && any(figs)) { | ||||||||
| if (keep == 'none') { | ||||||||
| res = res[!figs] # remove all | ||||||||
| } else { | ||||||||
| if (options$fig.show == 'hold') res = c(res[!figs], res[figs]) # move to the end | ||||||||
| figs = find_recordedplot(res) | ||||||||
| if (length(figs) && sum(figs) > 1) { | ||||||||
| if (keep %in% c('first', 'last')) { | ||||||||
| res = res[-(if (keep == 'last') head else tail)(which(figs), -1L)] | ||||||||
| } else { | ||||||||
| # keep only selected | ||||||||
| if (keep == 'index') res = res[-which(figs)[-keep.idx]] | ||||||||
| # merge low-level plotting changes | ||||||||
| if (keep == 'high') res = merge_low_plot(res, figs) | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| # number of plots in this chunk | ||||||||
| if (is.null(options$fig.num)) | ||||||||
| options$fig.num = if (length(res)) sum(sapply(res, function(x) { | ||||||||
| if (evaluate::is.recordedplot(x)) return(1) | ||||||||
| if (inherits(x, 'knit_image_paths')) return(length(x)) | ||||||||
| if (inherits(x, 'html_screenshot')) return(1) | ||||||||
| 0 | ||||||||
| })) else 0L | ||||||||
| # merge neighbor elements of the same class into one element | ||||||||
| for (cls in c('source', 'message', 'warning')) res = merge_class(res, cls) | ||||||||
| if (isTRUE(options$fig.beforecode)) res = fig_before_code(res) | ||||||||
| on.exit({ | ||||||||
| plot_counter(reset = TRUE) | ||||||||
| shot_counter(reset = TRUE) | ||||||||
| opts_knit$delete('plot_files') | ||||||||
| }, add = TRUE) # restore plot number | ||||||||
| output = unlist(wrap(res, options)) # wrap all results together | ||||||||
| res.after = run_hooks(before = FALSE, options, env) # run 'after' hooks | ||||||||
| output = paste(c(res.before, output, res.after), collapse = '') # insert hook results | ||||||||
| output = knit_hooks$get('chunk')(output, options) | ||||||||
| if (options$cache > 0) { | ||||||||
| # if cache.vars has been specifically provided, only cache these vars and no | ||||||||
| # need to look for objects in globalenv() | ||||||||
| obj.new = if (is.null(options$cache.vars)) setdiff(ls(globalenv(), all.names = TRUE), obj.before) | ||||||||
| copy_env(globalenv(), env, obj.new) | ||||||||
| objs = if (isFALSE(ev) || length(code) == 0) character(0) else | ||||||||
| options$cache.vars %n% codetools::findLocalsList(parse_only(code)) | ||||||||
| # make sure all objects to be saved exist in env | ||||||||
| objs = intersect(c(objs, obj.new), ls(env, all.names = TRUE)) | ||||||||
| if (options$autodep) { | ||||||||
| # you shall manually specify global object names if find_symbols() is not reliable | ||||||||
| cache$objects( | ||||||||
| objs, options$cache.globals %n% find_globals(code), options$label, | ||||||||
| options$cache.path | ||||||||
| ) | ||||||||
| dep_auto() | ||||||||
| } | ||||||||
| if (options$cache < 3) { | ||||||||
| if (options$cache.rebuild || !cache.exists) block_cache(options, res.orig, objs) | ||||||||
| } else block_cache(options, output, objs) | ||||||||
| } | ||||||||
| if (options$include) output else if (is.null(s <- options$indent)) '' else s | ||||||||
| } | ||||||||
| block_cache = function(options, output, objects) { | ||||||||
| hash = options$hash | ||||||||
| outname = cache_output_name(hash) | ||||||||
| assign(outname, output, envir = knit_global()) | ||||||||
| purge_cache(options) | ||||||||
| cache$library(options$cache.path, save = TRUE) | ||||||||
| cache$save(objects, outname, hash, lazy = options$cache.lazy) | ||||||||
| } | ||||||||
| purge_cache = function(options) { | ||||||||
| # purge my old cache and cache of chunks dependent on me | ||||||||
| cache$purge(paste0(valid_path( | ||||||||
| options$cache.path, c(options$label, dep_list$get(options$label)) | ||||||||
| ), '_????????????????????????????????')) | ||||||||
| } | ||||||||
| # open a graphical device for a chunk to record plots | ||||||||
| chunk_device = function(options, record = TRUE, tmp = tempfile()) { | ||||||||
| width = options$fig.width[1L] | ||||||||
| height = options$fig.height[1L] | ||||||||
| dev = fallback_dev(options$dev) | ||||||||
| dev.args = options$dev.args | ||||||||
| dpi = options$dpi | ||||||||
| # actually I should adjust the recording device according to dev, but here I | ||||||||
| # have only considered devices like png and tikz (because the measurement | ||||||||
| # results can be very different especially with the latter, see #1066), the | ||||||||
| # cairo_pdf device (#1235), and svg (#1705) | ||||||||
| if (identical(dev, 'png')) { | ||||||||
| do.call(grDevices::png, c(list( | ||||||||
| filename = tmp, width = width, height = height, units = 'in', res = dpi | ||||||||
| ), get_dargs(dev.args, 'png'))) | ||||||||
| } else if (identical(dev, 'ragg_png')) { | ||||||||
| do.call(ragg_png_dev, c(list( | ||||||||
| filename = tmp, width = width, height = height, units = 'in', res = dpi | ||||||||
| ), get_dargs(dev.args, 'ragg_png'))) | ||||||||
| } else if (identical(dev, 'tikz')) { | ||||||||
| dargs = c(list( | ||||||||
| file = tmp, width = width, height = height | ||||||||
| ), get_dargs(dev.args, 'tikz')) | ||||||||
| dargs$sanitize = options$sanitize; dargs$standAlone = options$external | ||||||||
| if (is.null(dargs$verbose)) dargs$verbose = FALSE | ||||||||
| do.call(tikz_dev, dargs) | ||||||||
| } else if (identical(dev, 'cairo_pdf')) { | ||||||||
| do.call(grDevices::cairo_pdf, c(list( | ||||||||
| filename = tmp, width = width, height = height | ||||||||
| ), get_dargs(dev.args, 'cairo_pdf'))) | ||||||||
| } else if (identical(dev, 'svg')) { | ||||||||
| do.call(grDevices::svg, c(list( | ||||||||
| filename = tmp, width = width, height = height | ||||||||
| ), get_dargs(dev.args, 'svg'))) | ||||||||
| } else if (identical(getOption('device'), pdf_null)) { | ||||||||
| if (!is.null(dev.args)) { | ||||||||
| dev.args = get_dargs(dev.args, 'pdf') | ||||||||
| dev.args = dev.args[intersect(names(dev.args), c('pointsize', 'bg'))] | ||||||||
| } | ||||||||
| do.call(pdf_null, c(list(width = width, height = height), dev.args)) | ||||||||
| } else dev.new(width = width, height = height) | ||||||||
| dev.control(displaylist = if (record) 'enable' else 'inhibit') | ||||||||
| } | ||||||||
| # fall back to a usable device (e.g., during R CMD check) | ||||||||
| fallback_dev = function(dev) { | ||||||||
| if (length(dev) != 1 || !getOption('knitr.device.fallback', xfun::is_R_CMD_check())) | ||||||||
| return(dev) | ||||||||
| choices = list( | ||||||||
| svg = c('png', 'jpeg', 'bmp'), cairo_pdf = c('pdf'), cairo_ps = c('postscript'), | ||||||||
| png = c('jpeg', 'svg', 'bmp'), jpeg = c('png', 'svg', 'bmp') | ||||||||
| ) | ||||||||
| # add choices provided by users | ||||||||
| choices = merge_list(choices, getOption('knitr.device.choices')) | ||||||||
| if (!dev %in% names(choices)) return(dev) # no fallback devices available | ||||||||
| # first test if the specified device actually works | ||||||||
| if (dev_available(dev)) return(dev) | ||||||||
| for (d in choices[[dev]]) if (dev_available(d)) { | ||||||||
| warning2("The device '", dev, "' is not operational; falling back to '", d, "'.") | ||||||||
| return(d) | ||||||||
| } | ||||||||
| dev # no fallback device found; you'll to run into an error soon | ||||||||
| } | ||||||||
| # filter out some results based on the numeric chunk option as indices | ||||||||
| filter_evaluate = function(res, opt, test) { | ||||||||
| if (length(res) == 0 || !is.numeric(opt) || !any(idx <- sapply(res, test))) | ||||||||
| return(res) | ||||||||
| idx = which(idx) | ||||||||
| idx = setdiff(idx, na.omit(idx[opt])) # indices of elements to remove | ||||||||
| if (length(idx) == 0) res else res[-idx] | ||||||||
| } | ||||||||
| # find recorded plots in the output of evaluate() | ||||||||
| find_recordedplot = function(x) { | ||||||||
| vapply(x, is_plot_output, logical(1)) | ||||||||
| } | ||||||||
| is_plot_output = function(x) { | ||||||||
| evaluate::is.recordedplot(x) || inherits(x, 'knit_image_paths') | ||||||||
| } | ||||||||
| # move plots before source code | ||||||||
| fig_before_code = function(x) { | ||||||||
| s = vapply(x, evaluate::is.source, logical(1)) | ||||||||
| if (length(s) == 0 || !any(s)) return(x) | ||||||||
| s = which(s) | ||||||||
| f = which(find_recordedplot(x)) | ||||||||
| f = f[f >= min(s)] # only move those plots after the first code block | ||||||||
| for (i in f) { | ||||||||
| j = max(s[s < i]) | ||||||||
| tmp = x[i]; x[[i]] = NULL; x = append(x, tmp, j - 1) | ||||||||
| s = which(vapply(x, evaluate::is.source, logical(1))) | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| # merge neighbor elements of the same class in a list returned by evaluate() | ||||||||
| merge_class = function(res, class = c('source', 'message', 'warning')) { | ||||||||
| class = match.arg(class) | ||||||||
| idx = if (length(res)) which(sapply(res, inherits, what = class)) | ||||||||
| if ((n <- length(idx)) <= 1) return(res) | ||||||||
| k1 = idx[1]; k2 = NULL; res1 = res[[k1]] | ||||||||
| el = c(source = 'src', message = 'message', warning = 'message')[class] | ||||||||
| for (i in 1:(n - 1)) { | ||||||||
| idx2 = idx[i + 1]; idx1 = idx[i] | ||||||||
| if (idx2 - idx1 == 1) { | ||||||||
| res2 = res[[idx2]] | ||||||||
| # merge warnings/messages only if next one is identical to previous one | ||||||||
| if (class == 'source' || identical(res1, res2) || | ||||||||
| (class == 'message' && !grepl('\n$', tail(res1[[el]], 1)))) { | ||||||||
| res[[k1]][[el]] = c(res[[k1]][[el]], res2[[el]]) | ||||||||
| k2 = c(k2, idx2) | ||||||||
| } else { | ||||||||
| k1 = idx2 | ||||||||
| res1 = res[[k1]] | ||||||||
| } | ||||||||
| } else k1 = idx2 | ||||||||
| } | ||||||||
| if (length(k2)) res = res[-k2] # remove lines that have been merged back | ||||||||
| res | ||||||||
| } | ||||||||
| # merge character output for output='hold', if the subsequent character is of | ||||||||
| # the same class(es) as the previous one (e.g. should not merge normal | ||||||||
| # characters with asis_output()) | ||||||||
| merge_character = function(res) { | ||||||||
| if ((n <- length(res)) <= 1) return(res) | ||||||||
| k = NULL | ||||||||
| for (i in 1:(n - 1)) { | ||||||||
| cls = class(res[[i]]) | ||||||||
| if (identical(cls, class(res[[i + 1]]))) { | ||||||||
| res[[i + 1]] = paste0(res[[i]], res[[i + 1]]) | ||||||||
| class(res[[i + 1]]) = cls | ||||||||
| k = c(k, i) | ||||||||
| } | ||||||||
| } | ||||||||
| if (length(k)) res = res[-k] | ||||||||
| res | ||||||||
| } | ||||||||
| call_inline = function(block) { | ||||||||
| if (opts_knit$get('progress')) print(block) | ||||||||
| in_dir(input_dir(), inline_exec(block)) | ||||||||
| } | ||||||||
| inline_exec = function( | ||||||||
| block, envir = knit_global(), hook = knit_hooks$get('inline'), | ||||||||
| hook_eval = knit_hooks$get('evaluate.inline') | ||||||||
| ) { | ||||||||
| # run inline code and substitute original texts | ||||||||
| code = block$code; input = block$input | ||||||||
| if ((n <- length(code)) == 0) return(input) # untouched if no code is found | ||||||||
| loc = block$location | ||||||||
| for (i in 1:n) { | ||||||||
| res = hook_eval(code[i], envir) | ||||||||
| if (inherits(res, 'knit_asis')) res = wrap(res, inline = TRUE) | ||||||||
| d = nchar(input) | ||||||||
| # replace with evaluated results | ||||||||
| stringr::str_sub(input, loc[i, 1], loc[i, 2]) = if (length(res)) { | ||||||||
| paste(hook(res), collapse = '') | ||||||||
| } else '' | ||||||||
| if (i < n) loc[(i + 1):n, ] = loc[(i + 1):n, ] - (d - nchar(input)) | ||||||||
| # may need to move back and forth because replacement may be longer or shorter | ||||||||
| } | ||||||||
| input | ||||||||
| } | ||||||||
| process_tangle = function(x) { | ||||||||
| UseMethod('process_tangle', x) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| process_tangle.block = function(x) { | ||||||||
| params = opts_chunk$merge(x$params) | ||||||||
| for (o in c('purl', 'eval', 'child')) { | ||||||||
| if (inherits(try(params[o] <- list(eval_lang(params[[o]]))), 'try-error')) { | ||||||||
| params[['purl']] = FALSE # if any of these options cannot be determined, don't purl | ||||||||
| } | ||||||||
| } | ||||||||
| if (isFALSE(params$purl)) return('') | ||||||||
| label = params$label; ev = params$eval | ||||||||
| if (params$engine != 'R') return(one_string(comment_out(knit_code$get(label)))) | ||||||||
| code = if (!isFALSE(ev) && !is.null(params$child)) { | ||||||||
| cmds = lapply(sc_split(params$child), knit_child) | ||||||||
| one_string(unlist(cmds)) | ||||||||
| } else knit_code$get(label) | ||||||||
| # read external code if exists | ||||||||
| if (!isFALSE(ev) && length(code) && any(grepl('read_chunk\\(.+\\)', code))) { | ||||||||
| eval(parse_only(unlist(stringr::str_extract_all(code, 'read_chunk\\(([^)]+)\\)')))) | ||||||||
| } | ||||||||
| code = parse_chunk(code) | ||||||||
| if (isFALSE(ev)) code = comment_out(code, params$comment, newline = FALSE) | ||||||||
| if (opts_knit$get('documentation') == 0L) return(one_string(code)) | ||||||||
| label_code(code, x$params.src) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| process_tangle.inline = function(x) { | ||||||||
| output = if (opts_knit$get('documentation') == 2L) { | ||||||||
| output = one_string(line_prompt(x$input.src, "#' ", "#' ")) | ||||||||
| } else '' | ||||||||
| code = x$code | ||||||||
| if (length(code) == 0L) return(output) | ||||||||
| if (getOption('knitr.purl.inline', FALSE)) output = c(output, code) | ||||||||
| idx = grepl('knit_child\\(.+\\)', code) | ||||||||
| if (any(idx)) { | ||||||||
| cout = sapply(code[idx], function(z) eval(parse_only(z))) | ||||||||
| output = c(output, cout, '') | ||||||||
| } | ||||||||
| one_string(output) | ||||||||
| } | ||||||||
| # add a label [and extra chunk options] to a code chunk | ||||||||
| label_code = function(code, label) { | ||||||||
| code = one_string(c('', code, '')) | ||||||||
| paste0('## ----', stringr::str_pad(label, max(getOption('width') - 11L, 0L), 'right', '-'), | ||||||||
| '----', code) | ||||||||
| } | ||||||||
| as.source = function(code) { | ||||||||
| list(structure(list(src = code), class = 'source')) | ||||||||
| } | ||||||||
| knitr/R/output.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Knit a document | ||||||||
| #' | ||||||||
| #' This function takes an input file, extracts the R code in it according to a | ||||||||
| #' list of patterns, evaluates the code and writes the output in another file. | ||||||||
| #' It can also tangle R source code from the input document (\code{purl()} is a | ||||||||
| #' wrapper to \code{knit(..., tangle = TRUE)}). The \code{knitr.purl.inline} | ||||||||
| #' option can be used to also tangle the code of inline expressions (disabled by | ||||||||
| #' default). | ||||||||
| #' | ||||||||
| #' For most of the time, it is not necessary to set any options outside the | ||||||||
| #' input document; in other words, a single call like | ||||||||
| #' \code{knit('my_input.Rnw')} is usually enough. This function will try to | ||||||||
| #' determine many internal settings automatically. For the sake of | ||||||||
| #' reproducibility, it is better practice to include the options inside the | ||||||||
| #' input document (to be self-contained), instead of setting them before | ||||||||
| #' knitting the document. | ||||||||
| #' | ||||||||
| #' First the filename of the output document is determined in this way: | ||||||||
| #' \file{foo.Rnw} generates \file{foo.tex}, and other filename extensions like | ||||||||
| #' \file{.Rtex}, \file{.Rhtml} (\file{.Rhtm}) and \file{.Rmd} | ||||||||
| #' (\file{.Rmarkdown}) will generate \file{.tex}, \file{.html} and \file{.md} | ||||||||
| #' respectively. For other types of files, if the filename contains | ||||||||
| #' \samp{_knit_}, this part will be removed in the output file, e.g., | ||||||||
| #' \file{foo_knit_.html} creates the output \file{foo.html}; if \samp{_knit_} is | ||||||||
| #' not found in the filename, \file{foo.ext} will produce \file{foo.txt} if | ||||||||
| #' \code{ext} is not \code{txt}, otherwise the output is \file{foo-out.txt}. If | ||||||||
| #' \code{tangle = TRUE}, \file{foo.ext} generates an R script \file{foo.R}. | ||||||||
| #' | ||||||||
| #' We need a set of syntax to identify special markups for R code chunks and R | ||||||||
| #' options, etc. The syntax is defined in a pattern list. All built-in pattern | ||||||||
| #' lists can be found in \code{all_patterns} (call it \code{apat}). First | ||||||||
| #' \pkg{knitr} will try to decide the pattern list based on the filename | ||||||||
| #' extension of the input document, e.g. \samp{Rnw} files use the list | ||||||||
| #' \code{apat$rnw}, \samp{tex} uses the list \code{apat$tex}, \samp{brew} uses | ||||||||
| #' \code{apat$brew} and HTML files use \code{apat$html}; for unkown extensions, | ||||||||
| #' the content of the input document is matched against all pattern lists to | ||||||||
| #' automatically determine which pattern list is being used. You can also | ||||||||
| #' manually set the pattern list using the \code{\link{knit_patterns}} object or | ||||||||
| #' the \code{\link{pat_rnw}} series functions in advance and \pkg{knitr} will | ||||||||
| #' respect the setting. | ||||||||
| #' | ||||||||
| #' According to the output format (\code{opts_knit$get('out.format')}), a set of | ||||||||
| #' output hooks will be set to mark up results from R (see | ||||||||
| #' \code{\link{render_latex}}). The output format can be LaTeX, Sweave and HTML, | ||||||||
| #' etc. The output hooks decide how to mark up the results (you can customize | ||||||||
| #' the hooks). | ||||||||
| #' | ||||||||
| #' The name \code{knit} comes from its counterpart \samp{weave} (as in Sweave), | ||||||||
| #' and the name \code{purl} (as \samp{tangle} in Stangle) comes from a knitting | ||||||||
| #' method `knit one, purl one'. | ||||||||
| #' | ||||||||
| #' If the input document has child documents, they will also be compiled | ||||||||
| #' recursively. See \code{\link{knit_child}}. | ||||||||
| #' | ||||||||
| #' See the package website and manuals in the references to know more about | ||||||||
| #' \pkg{knitr}, including the full documentation of chunk options and demos, | ||||||||
| #' etc. | ||||||||
| #' @param input Path to the input file. | ||||||||
| #' @param output Path to the output file for \code{knit()}. If \code{NULL}, this | ||||||||
| #' function will try to guess a default, which will be under the current | ||||||||
| #' working directory. | ||||||||
| #' @param tangle Boolean; whether to tangle the R code from the input file (like | ||||||||
| #' \code{utils::\link{Stangle}}). | ||||||||
| #' @param text A character vector. This is an alternative way to provide the | ||||||||
| #' input file. | ||||||||
| #' @param quiet Boolean; suppress the progress bar and messages? | ||||||||
| #' @param envir Environment in which code chunks are to be evaluated, for | ||||||||
| #' example, \code{\link{parent.frame}()}, \code{\link{new.env}()}, or | ||||||||
| #' \code{\link{globalenv}()}). | ||||||||
| #' @param encoding Encoding of the input file; always assumed to be UTF-8 (i.e., | ||||||||
| #' this argument is effectively ignored). | ||||||||
| #' @return The compiled document is written into the output file, and the path | ||||||||
| #' of the output file is returned. If the \code{text} argument is not | ||||||||
| #' \code{NULL}, the compiled output is returned as a character vector. In | ||||||||
| #' other words, if you provide a file input, you get an output filename; if | ||||||||
| #' you provide a character vector input, you get a character vector output. | ||||||||
| #' @note The working directory when evaluating R code chunks is the directory of | ||||||||
| #' the input document by default, so if the R code involves external files | ||||||||
| #' (like \code{read.table()}), it is better to put these files under the same | ||||||||
| #' directory of the input document so that we can use relative paths. However, | ||||||||
| #' it is possible to change this directory with the package option | ||||||||
| #' \code{\link{opts_knit}$set(root.dir = ...)} so all paths in code chunks are | ||||||||
| #' relative to this \code{root.dir}. It is not recommended to change the | ||||||||
| #' working directory via \code{\link{setwd}()} in a code chunk, because it may | ||||||||
| #' lead to terrible consequences (e.g. figure and cache files may be written | ||||||||
| #' to wrong places). If you do use \code{setwd()}, please note that | ||||||||
| #' \pkg{knitr} will always restore the working directory to the original one. | ||||||||
| #' Whenever you feel confused, print \code{getwd()} in a code chunk to see | ||||||||
| #' what the working directory really is. | ||||||||
| #' | ||||||||
| #' If the \code{output} argument is a file path, it is strongly recommended to | ||||||||
| #' be in the current working directory (e.g. \file{foo.tex} instead of | ||||||||
| #' \file{somewhere/foo.tex}), especially when the output has external | ||||||||
| #' dependencies such as figure files. If you want to write the output to a | ||||||||
| #' different directory, it is recommended to set the working directory to that | ||||||||
| #' directory before you knit a document. For example, if the source document | ||||||||
| #' is \file{foo.Rmd} and the expected output is \file{out/foo.md}, you can | ||||||||
| #' write \code{setwd('out/'); knit('../foo.Rmd')} instead of | ||||||||
| #' \code{knit('foo.Rmd', 'out/foo.md')}. | ||||||||
| #' | ||||||||
| #' N.B. There is no guarantee that the R script generated by \code{purl()} can | ||||||||
| #' reproduce the computation done in \code{knit()}. The \code{knit()} process | ||||||||
| #' can be fairly complicated (special values for chunk options, custom chunk | ||||||||
| #' hooks, computing engines besides R, and the \code{envir} argument, etc). If | ||||||||
| #' you want to reproduce the computation in a report generated by | ||||||||
| #' \code{knit()}, be sure to use \code{knit()}, instead of merely executing | ||||||||
| #' the R script generated by \code{purl()}. This seems to be obvious, but some | ||||||||
| #' people | ||||||||
| #' \href{https://r.789695.n4.nabble.com/R-CMD-check-for-the-R-code-from-vignettes-td4691457.html}{just | ||||||||
| #' do not get it}. | ||||||||
| #' @export | ||||||||
| #' @references Package homepage: \url{https://yihui.org/knitr/}. The \pkg{knitr} | ||||||||
| #' \href{https://yihui.org/knitr/demo/manual/}{main manual}: and | ||||||||
| #' \href{https://yihui.org/knitr/demo/graphics/}{graphics manual}. | ||||||||
| #' | ||||||||
| #' See \code{citation('knitr')} for the citation information. | ||||||||
| #' @examples library(knitr) | ||||||||
| #' (f = system.file('examples', 'knitr-minimal.Rnw', package = 'knitr')) | ||||||||
| #' knit(f) # compile to tex | ||||||||
| #' | ||||||||
| #' purl(f) # tangle R code | ||||||||
| #' purl(f, documentation = 0) # extract R code only | ||||||||
| #' purl(f, documentation = 2) # also include documentation | ||||||||
| #' | ||||||||
| #' unlink(c('knitr-minimal.tex', 'knitr-minimal.R', 'figure'), recursive = TRUE) | ||||||||
| knit = function( | ||||||||
| input, output = NULL, tangle = FALSE, text = NULL, quiet = FALSE, | ||||||||
| envir = parent.frame(), encoding = 'UTF-8' | ||||||||
| ) { | ||||||||
| in.file = !missing(input) && is.character(input) # is input provided? | ||||||||
| oconc = knit_concord$get(); on.exit(knit_concord$set(oconc), add = TRUE) | ||||||||
| if (child_mode()) { | ||||||||
| setwd(opts_knit$get('output.dir')) # always restore original working dir | ||||||||
| # in child mode, input path needs to be adjusted | ||||||||
| if (in.file && !is_abs_path(input)) { | ||||||||
| input = paste0(opts_knit$get('child.path'), input) | ||||||||
| input = file.path(input_dir(TRUE), input) | ||||||||
| } | ||||||||
| # respect the quiet argument in child mode (#741) | ||||||||
| optk = opts_knit$get(); on.exit(opts_knit$set(optk), add = TRUE) | ||||||||
| opts_knit$set(progress = opts_knit$get('progress') && !quiet) | ||||||||
| quiet = !opts_knit$get('progress') | ||||||||
| } else { | ||||||||
| opts_knit$set(output.dir = getwd()) # record working directory in 1st run | ||||||||
| knit_log$restore() | ||||||||
| on.exit(chunk_counter(reset = TRUE), add = TRUE) # restore counter | ||||||||
| adjust_opts_knit() | ||||||||
| # turn off fancy quotes, use a null pdf device to record graphics | ||||||||
| oopts = options( | ||||||||
| useFancyQuotes = FALSE, device = pdf_null, knitr.in.progress = TRUE | ||||||||
| ) | ||||||||
| on.exit(options(oopts), add = TRUE) | ||||||||
| # restore chunk options after parent exits | ||||||||
| optc = opts_chunk$get(); on.exit(opts_chunk$restore(optc), add = TRUE) | ||||||||
| ocode = knit_code$get(); on.exit(knit_code$restore(ocode), add = TRUE) | ||||||||
| on.exit(opts_current$restore(), add = TRUE) | ||||||||
| optk = opts_knit$get(); on.exit(opts_knit$set(optk), add = TRUE) | ||||||||
| opts_knit$set(tangle = tangle, progress = opts_knit$get('progress') && !quiet) | ||||||||
| } | ||||||||
| # store the evaluation environment and restore on exit | ||||||||
| oenvir = .knitEnv$knit_global; .knitEnv$knit_global = envir | ||||||||
| on.exit({.knitEnv$knit_global = oenvir}, add = TRUE) | ||||||||
| ext = 'unknown' | ||||||||
| if (in.file) { | ||||||||
| input.dir = .knitEnv$input.dir; on.exit({.knitEnv$input.dir = input.dir}, add = TRUE) | ||||||||
| .knitEnv$input.dir = dirname(input) # record input dir | ||||||||
| ext = tolower(file_ext(input)) | ||||||||
| if ((is.null(output) || is.na(output)) && !child_mode()) | ||||||||
| output = basename(auto_out_name(input, ext)) | ||||||||
| # do not run purl() when the output is newer than input (the output might | ||||||||
| # have been generated by hook_purl) | ||||||||
| if (is.character(output) && !child_mode()) { | ||||||||
| out.purl = with_ext(input, 'R') | ||||||||
| if (xfun::same_path(output, out.purl) && tangle && file_test('-nt', out.purl, input)) | ||||||||
| return(out.purl) | ||||||||
| otangle = .knitEnv$tangle.file # the tangled R script | ||||||||
| .knitEnv$tangle.file = normalizePath(out.purl, mustWork = FALSE) | ||||||||
| .knitEnv$tangle.start = FALSE | ||||||||
| on.exit({.knitEnv$tangle.file = otangle; .knitEnv$tangle.start = NULL}, add = TRUE) | ||||||||
| } | ||||||||
| if (is.null(getOption('tikzMetricsDictionary'))) { | ||||||||
| options(tikzMetricsDictionary = tikz_dict(input)) # cache tikz dictionary | ||||||||
| on.exit(options(tikzMetricsDictionary = NULL), add = TRUE) | ||||||||
| } | ||||||||
| knit_concord$set(infile = input, outfile = output) | ||||||||
| } | ||||||||
| text = if (is.null(text)) xfun::read_utf8(input) else split_lines(text) | ||||||||
| if (!length(text)) { | ||||||||
| if (is.character(output)) file.create(output) | ||||||||
| return(output) # a trivial case: create an empty file and exit | ||||||||
| } | ||||||||
| apat = all_patterns; opat = knit_patterns$get() | ||||||||
| on.exit(knit_patterns$restore(opat), add = TRUE) | ||||||||
| if (length(opat) == 0 || all(vapply(opat, is.null, logical(1)))) { | ||||||||
| # use ext if cannot auto detect pattern | ||||||||
| if (is.null(pattern <- detect_pattern(text, ext))) { | ||||||||
| # nothing to be executed; just return original input | ||||||||
| if (is.null(output)) { | ||||||||
| return(if (tangle) '' else one_string(text)) | ||||||||
| } else { | ||||||||
| write_utf8(if (tangle) '' else text, output) | ||||||||
| return(output) | ||||||||
| } | ||||||||
| } | ||||||||
| if (!(pattern %in% names(apat))) stop( | ||||||||
| "a pattern list cannot be automatically found for the file extension '", | ||||||||
| ext, "' in built-in pattern lists; ", | ||||||||
| 'see ?knit_patterns on how to set up customized patterns' | ||||||||
| ) | ||||||||
| set_pattern(pattern) | ||||||||
| if (pattern == 'rnw' && length(sweave_lines <- which_sweave(text)) > 0) | ||||||||
| remind_sweave(if (in.file) input, sweave_lines) | ||||||||
| opts_knit$set(out.format = switch( | ||||||||
| pattern, rnw = 'latex', tex = 'latex', html = 'html', md = 'markdown', | ||||||||
| rst = 'rst', brew = 'brew', asciidoc = 'asciidoc', textile = 'textile' | ||||||||
| )) | ||||||||
| } | ||||||||
| if (is.null(out_format())) auto_format(ext) | ||||||||
| params = NULL # the params field from YAML | ||||||||
| if (out_format('markdown')) { | ||||||||
| if (child_mode()) { | ||||||||
| # in child mode, strip off the YAML metadata in Markdown if exists | ||||||||
| if (grepl('^---\\s*$', text[1])) { | ||||||||
| i = grep('^---\\s*$', text) | ||||||||
| if (length(i) >= 2) text[1:i[2]] = '' | ||||||||
| } | ||||||||
| } else { | ||||||||
| params = knit_params(text) | ||||||||
| params = if (length(params)) | ||||||||
| c('params <-', capture.output(dput(flatten_params(params), '')), '') | ||||||||
| .knitEnv$tangle.params = params # for hook_purl() | ||||||||
| } | ||||||||
| } | ||||||||
| # change output hooks only if they are not set beforehand | ||||||||
| if (identical(knit_hooks$get(names(.default.hooks)), .default.hooks) && !child_mode()) { | ||||||||
| getFromNamespace(paste('render', out_format(), sep = '_'), 'knitr')() | ||||||||
| on.exit(knit_hooks$set(.default.hooks), add = TRUE) | ||||||||
| } | ||||||||
| progress = opts_knit$get('progress') | ||||||||
| if (in.file && !quiet) message(ifelse(progress, '\n\n', ''), 'processing file: ', input) | ||||||||
| res = process_file(text, output) | ||||||||
| res = one_string(knit_hooks$get('document')(res)) | ||||||||
| if (tangle) res = c(params, res) | ||||||||
| if (!is.null(output)) write_utf8(res, output) | ||||||||
| if (!child_mode()) { | ||||||||
| dep_list$restore() # empty dependency list | ||||||||
| .knitEnv$labels = NULL | ||||||||
| } | ||||||||
| if (in.file && is.character(output) && file.exists(output)) { | ||||||||
| concord_gen(input, output) | ||||||||
| if (!quiet) message('output file: ', output, ifelse(progress, '\n', '')) | ||||||||
| } | ||||||||
| output %n% res | ||||||||
| } | ||||||||
| #' @rdname knit | ||||||||
| #' @param documentation An integer specifying the level of documentation to add to | ||||||||
| #' the tangled script. \code{0} means to output pure code, discarding all text chunks); | ||||||||
| #' \code{1} (the default) means to add the chunk headers to the code; \code{2} means to | ||||||||
| #' add all text chunks to code as roxygen comments. | ||||||||
| #' @param ... arguments passed to \code{\link{knit}()} from \code{purl()} | ||||||||
| #' @export | ||||||||
| purl = function(..., documentation = 1L) { | ||||||||
| doc = opts_knit$get('documentation'); on.exit(opts_knit$set(documentation = doc)) | ||||||||
| opts_knit$set(documentation = documentation) | ||||||||
| knit(..., tangle = TRUE) | ||||||||
| } | ||||||||
| process_file = function(text, output) { | ||||||||
| groups = split_file(lines = text) | ||||||||
| n = length(groups); res = character(n) | ||||||||
| tangle = opts_knit$get('tangle') | ||||||||
| # when in R CMD check, turn off the progress bar (R-exts said the progress bar | ||||||||
| # was not appropriate for non-interactive mode, and I don't want to argue) | ||||||||
| progress = opts_knit$get('progress') && !is_R_CMD_check() | ||||||||
| if (progress) { | ||||||||
| pb = txtProgressBar(0, n, char = '.', style = 3) | ||||||||
| on.exit(close(pb), add = TRUE) | ||||||||
| } | ||||||||
| wd = getwd() | ||||||||
| for (i in 1:n) { | ||||||||
| if (!is.null(.knitEnv$terminate)) { | ||||||||
| if (!child_mode() || !.knitEnv$terminate_fully) { | ||||||||
| # reset the internal variable `terminate` in the top parent | ||||||||
| res[i] = one_string(.knitEnv$terminate) | ||||||||
| knit_exit(NULL, NULL) | ||||||||
| } | ||||||||
| break # must have called knit_exit(), so exit early | ||||||||
| } | ||||||||
| if (progress) { | ||||||||
| setTxtProgressBar(pb, i) | ||||||||
| if (!tangle) cat('\n') # under tangle mode, only show one progress bar | ||||||||
| flush.console() | ||||||||
| } | ||||||||
| group = groups[[i]] | ||||||||
| res[i] = withCallingHandlers( | ||||||||
| if (tangle) process_tangle(group) else process_group(group), | ||||||||
| error = function(e) { | ||||||||
| setwd(wd) | ||||||||
| cat(res, sep = '\n', file = output %n% '') | ||||||||
| message( | ||||||||
| 'Quitting from lines ', paste(current_lines(i), collapse = '-'), | ||||||||
| ' (', knit_concord$get('infile'), ') ' | ||||||||
| ) | ||||||||
| } | ||||||||
| ) | ||||||||
| } | ||||||||
| if (!tangle) res = insert_header(res) # insert header | ||||||||
| # output line numbers | ||||||||
| if (concord_mode()) knit_concord$set(outlines = line_count(res)) | ||||||||
| print_knitlog() | ||||||||
| if (tangle) res = strip_white(res) | ||||||||
| res | ||||||||
| } | ||||||||
| auto_out_name = function(input, ext = tolower(file_ext(input))) { | ||||||||
| base = sans_ext(input) | ||||||||
| name = if (opts_knit$get('tangle')) c(base, '.R') else | ||||||||
| if (ext %in% c('rnw', 'snw')) c(base, '.tex') else | ||||||||
| if (ext %in% c('rmd', 'rmarkdown', 'rhtml', 'rhtm', 'rtex', 'stex', 'rrst', 'rtextile')) | ||||||||
| c(base, '.', substring(ext, 2L)) else | ||||||||
| if (grepl('_knit_', input)) sub('_knit_', '', input) else | ||||||||
| if (ext != 'txt') c(base, '.txt') else c(base, '-out.', ext) | ||||||||
| paste(name, collapse = '') | ||||||||
| } | ||||||||
| # determine output format based on file extension | ||||||||
| ext2fmt = c( | ||||||||
| rnw = 'latex', snw = 'latex', tex = 'latex', rtex = 'latex', stex = 'latex', | ||||||||
| htm = 'html', html = 'html', rhtml = 'html', rhtm = 'html', | ||||||||
| md = 'markdown', markdown = 'markdown', rmd = 'markdown', rmarkdown = 'markdown', | ||||||||
| brew = 'brew', rst = 'rst', rrst = 'rst' | ||||||||
| ) | ||||||||
| auto_format = function(ext) { | ||||||||
| fmt = ext2fmt[ext] | ||||||||
| if (is.na(fmt)) fmt = { | ||||||||
| warning('cannot automatically decide the output format') | ||||||||
| 'unknown' | ||||||||
| } | ||||||||
| opts_knit$set(out.format = fmt) | ||||||||
| invisible(fmt) | ||||||||
| } | ||||||||
| #' Knit a child document | ||||||||
| #' | ||||||||
| #' This function knits a child document and returns a character string to input | ||||||||
| #' the result into the main document. It is designed to be used in the chunk | ||||||||
| #' option \code{child} and serves as the alternative to the | ||||||||
| #' \command{SweaveInput} command in Sweave. | ||||||||
| #' @param ... Arguments passed to \code{\link{knit}}. | ||||||||
| #' @param options A list of chunk options to be used as global options inside | ||||||||
| #' the child document. When one uses the \code{child} | ||||||||
| #' option in a parent chunk, the chunk options of the parent chunk will be | ||||||||
| #' passed to the \code{options} argument here. Ignored if not a list. | ||||||||
| #' @inheritParams knit | ||||||||
| #' @return A character string of the content of the compiled child document is | ||||||||
| #' returned as a character string so it can be written back to the parent | ||||||||
| #' document directly. | ||||||||
| #' @references \url{https://yihui.org/knitr/demo/child/} | ||||||||
| #' @note This function is not supposed be called directly like | ||||||||
| #' \code{\link{knit}()}; instead it must be placed in a parent document to let | ||||||||
| #' \code{\link{knit}()} call it indirectly. | ||||||||
| #' | ||||||||
| #' The path of the child document is determined relative to the parent document. | ||||||||
| #' @export | ||||||||
| #' @examples # you can write \Sexpr{knit_child('child-doc.Rnw')} in an Rnw file 'main.Rnw' | ||||||||
| #' # to input results from child-doc.Rnw in main.tex | ||||||||
| #' | ||||||||
| #' # comment out the child doc by \Sexpr{knit_child('child-doc.Rnw', eval = FALSE)} | ||||||||
| knit_child = function(..., options = NULL, envir = knit_global()) { | ||||||||
| child = child_mode() | ||||||||
| opts_knit$set(child = TRUE) # yes, in child mode now | ||||||||
| on.exit(opts_knit$set(child = child)) # restore child status | ||||||||
| if (is.list(options)) { | ||||||||
| options$label = options$child = NULL # do not need to pass the parent label on | ||||||||
| if (length(options)) { | ||||||||
| optc = opts_chunk$get(names(options), drop = FALSE); opts_chunk$set(options) | ||||||||
| # if user did not touch opts_chunk$set() in child, restore the chunk option | ||||||||
| on.exit({ | ||||||||
| for (i in names(options)) if (identical(options[[i]], opts_chunk$get(i))) | ||||||||
| opts_chunk$set(optc[i]) | ||||||||
| }, add = TRUE) | ||||||||
| } | ||||||||
| } | ||||||||
| res = knit(..., tangle = opts_knit$get('tangle'), envir = envir) | ||||||||
| one_string(c('', res)) | ||||||||
| } | ||||||||
| #' Exit knitting early | ||||||||
| #' | ||||||||
| #' Sometimes we may want to exit the knitting process early, and completely | ||||||||
| #' ignore the rest of the document. This function provides a mechanism to | ||||||||
| #' terminate \code{\link{knit}()}. | ||||||||
| #' @param append A character vector to be appended to the results from | ||||||||
| #' \code{knit()} so far. By default, this is \samp{\end{document}} for LaTeX | ||||||||
| #' output, and \samp{</body></html>} for HTML output, to make the output | ||||||||
| #' document complete. For other types of output, it is an empty string. | ||||||||
| #' @param fully Whether to fully exit the knitting process if \code{knit_exit()} | ||||||||
| #' is called from a child document. If \code{FALSE}, only exit the knitting | ||||||||
| #' process of the child document. | ||||||||
| #' @return Invisible \code{NULL}. An internal signal is set up (as a side | ||||||||
| #' effect) to notify \code{knit()} to quit as if it had reached the end of the | ||||||||
| #' document. | ||||||||
| #' @export | ||||||||
| #' @examples # see https://github.com/yihui/knitr-examples/blob/master/096-knit-exit.Rmd | ||||||||
| knit_exit = function(append, fully = TRUE) { | ||||||||
| if (missing(append)) append = if (out_format(c('latex', 'sweave', 'listings'))) | ||||||||
| '\\end{document}' else if (out_format('html')) '</body>\n</html>' else '' | ||||||||
| .knitEnv$terminate = append # use this terminate variable to notify knit() | ||||||||
| .knitEnv$terminate_fully = fully | ||||||||
| invisible() | ||||||||
| } | ||||||||
| knit_log = new_defaults() # knitr log for errors, warnings and messages | ||||||||
| #' Wrap evaluated results for output | ||||||||
| #' | ||||||||
| #' @param x output from \code{evaluate::\link{evaluate}()} | ||||||||
| #' @param options List of options used to control output | ||||||||
| #' @noRd | ||||||||
| wrap = function(x, options = list(), ...) { | ||||||||
| UseMethod('wrap', x) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| wrap.list = function(x, options = list()) { | ||||||||
| if (length(x) == 0L) return(x) | ||||||||
| lapply(x, wrap, options) | ||||||||
| } | ||||||||
| # ignore unknown classes | ||||||||
| #' @export | ||||||||
| wrap.default = function(x, options) return() | ||||||||
| #' @export | ||||||||
| wrap.character = function(x, options) { | ||||||||
| if (options$results == 'hide') return() | ||||||||
| if (output_asis(x, options)) { | ||||||||
| if (!out_format('latex')) return(x) # latex output still need a tweak | ||||||||
| } else x = comment_out(x, options$comment) | ||||||||
| knit_hooks$get('output')(x, options) | ||||||||
| } | ||||||||
| # If you provide a custom print function that returns a character object of | ||||||||
| # class 'knit_asis', it will be written as is. | ||||||||
| #' @export | ||||||||
| wrap.knit_asis = function(x, options, inline = FALSE) { | ||||||||
| m = attr(x, 'knit_meta') | ||||||||
| knit_meta_add(m, if (missing(options)) '' else options$label) | ||||||||
| if (!missing(options)) { | ||||||||
| if (options$cache > 0 && isFALSE(attr(x, 'knit_cacheable'))) stop( | ||||||||
| "The code chunk '", options$label, "' is not cacheable; ", | ||||||||
| "please use the chunk option cache=FALSE on this chunk" | ||||||||
| ) | ||||||||
| # store metadata in an object named of the form .hash_meta when cache=TRUE | ||||||||
| if (length(m) && options$cache == 3) | ||||||||
| assign(cache_meta_name(options$hash), m, envir = knit_global()) | ||||||||
| if (inherits(x, 'knit_asis_htmlwidget')) { | ||||||||
| options$fig.cur = plot_counter() | ||||||||
| options = reduce_plot_opts(options) | ||||||||
| return(add_html_caption(options, x)) | ||||||||
| } | ||||||||
| } | ||||||||
| x = as.character(x) | ||||||||
| if (!out_format('latex') || inline) return(x) | ||||||||
| # latex output need the \end{kframe} trick | ||||||||
| options$results = 'asis' | ||||||||
| knit_hooks$get('output')(x, options) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| wrap.source = function(x, options) { | ||||||||
| if (isFALSE(options$echo)) return() | ||||||||
| src = sub('\n$', '', x$src) | ||||||||
| if (!options$collapse && options$strip.white) src = strip_white(src) | ||||||||
| if (is_blank(src)) return() # an empty chunk | ||||||||
| knit_hooks$get('source')(src, options) | ||||||||
| } | ||||||||
| msg_wrap = function(message, type, options) { | ||||||||
| # when the output format is LaTeX, do not wrap messages (let LaTeX deal with wrapping) | ||||||||
| if (!length(grep('\n', message)) && !out_format(c('latex', 'listings', 'sweave'))) | ||||||||
| message = stringr::str_wrap(message, width = getOption('width')) | ||||||||
| knit_log$set(setNames( | ||||||||
| list(c(knit_log$get(type), paste0('Chunk ', options$label, ':\n ', message))), | ||||||||
| type | ||||||||
| )) | ||||||||
| message = msg_sanitize(message, type) | ||||||||
| knit_hooks$get(type)(comment_out(message, options$comment), options) | ||||||||
| } | ||||||||
| # set options(knitr.sanitize.errors = TRUE) to hide error messages, etc | ||||||||
| msg_sanitize = function(message, type) { | ||||||||
| type = match.arg(type, c('error', 'warning', 'message')) | ||||||||
| opt = getOption(sprintf('knitr.sanitize.%ss', type), FALSE) | ||||||||
| if (isTRUE(opt)) message = switch( | ||||||||
| type, error = 'An error occurred', warning = 'A warning was emitted', | ||||||||
| message = 'A message was emitted' | ||||||||
| ) else if (is.character(opt)) message = opt | ||||||||
| message | ||||||||
| } | ||||||||
| #' @export | ||||||||
| wrap.warning = function(x, options) { | ||||||||
| call = if (is.null(x$call)) '' else { | ||||||||
| call = deparse(x$call)[1] | ||||||||
| if (call == 'eval(expr, envir, enclos)') '' else paste(' in', call) | ||||||||
| } | ||||||||
| msg_wrap(sprintf('Warning%s: %s', call, x$message), 'warning', options) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| wrap.message = function(x, options) { | ||||||||
| msg_wrap(paste(x$message, collapse = ''), 'message', options) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| wrap.error = function(x, options) { | ||||||||
| msg_wrap(as.character(x), 'error', options) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| wrap.recordedplot = function(x, options) { | ||||||||
| # figure number sequence for multiple plots | ||||||||
| fig.cur = plot_counter() | ||||||||
| options$fig.cur = fig.cur # put fig num in options | ||||||||
| name = fig_path('', options, number = fig.cur) | ||||||||
| in_base_dir( | ||||||||
| # automatically creates dir for plots | ||||||||
| if (!file_test('-d', dirname(name))) | ||||||||
| dir.create(dirname(name), recursive = TRUE) | ||||||||
| ) | ||||||||
| # vectorize over dev, ext and dpi: save multiple versions of the plot | ||||||||
| files = mapply( | ||||||||
| save_plot, width = options$fig.width, height = options$fig.height, | ||||||||
| dev = options$dev, ext = options$fig.ext, dpi = options$dpi, | ||||||||
| MoreArgs = list(plot = x, name = name, options = options), SIMPLIFY = FALSE | ||||||||
| ) | ||||||||
| opts_knit$append(plot_files = unlist(files)) | ||||||||
| if (options$fig.show == 'hide') return('') | ||||||||
| in_base_dir(run_hook_plot(files[[1]], reduce_plot_opts(options))) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| wrap.knit_image_paths = function(x, options = opts_chunk$get(), inline = FALSE) { | ||||||||
| if (options$fig.show == 'hide') return('') | ||||||||
| # remove the automatically set out.width when fig.retina is set, otherwise the | ||||||||
| # size of external images embedded via include_graphics() will be set to | ||||||||
| # fig.width * dpi in fix_options() | ||||||||
| if (is.numeric(r <- options$fig.retina)) { | ||||||||
| w1 = options$out.width | ||||||||
| w2 = options$fig.width * options$dpi / r | ||||||||
| if (length(w1) * length(w2) == 1 && is.numeric(w1) && w1 == w2) | ||||||||
| options['out.width'] = list(NULL) | ||||||||
| } | ||||||||
| options$fig.num = options$fig.num %n% length(x) | ||||||||
| dpi = attr(x, 'dpi') %n% options$dpi | ||||||||
| hook = knit_hooks$get('plot') | ||||||||
| paste(unlist(lapply(seq_along(x), function(i) { | ||||||||
| options$fig.cur = plot_counter() | ||||||||
| if (is.null(options[['out.width']])) | ||||||||
| options['out.width'] = list(raster_dpi_width(x[i], dpi)) | ||||||||
| hook(x[i], reduce_plot_opts(options)) | ||||||||
| })), collapse = '') | ||||||||
| } | ||||||||
| #' @export | ||||||||
| wrap.html_screenshot = function(x, options = opts_chunk$get(), inline = FALSE) { | ||||||||
| ext = x$extension | ||||||||
| in_base_dir({ | ||||||||
| i = plot_counter() | ||||||||
| if (is.null(f <- x$file)) { | ||||||||
| f = fig_path(ext, options, i) | ||||||||
| dir.create(dirname(f), recursive = TRUE, showWarnings = FALSE) | ||||||||
| writeBin(x$image, f, useBytes = TRUE) | ||||||||
| } | ||||||||
| options$fig.cur = i | ||||||||
| options = reduce_plot_opts(options) | ||||||||
| if (!is.null(x$url) && is.null(options$fig.link)) options$fig.link = x$url | ||||||||
| run_hook_plot(f, options) | ||||||||
| }) | ||||||||
| } | ||||||||
| # record plot filenames in opts_knit$get('plot_files'), including those from R | ||||||||
| # code and auto screenshots of HTML widgets, etc. Then run the plot hook. | ||||||||
| run_hook_plot = function(x, options) { | ||||||||
| opts_knit$append(plot_files = x) | ||||||||
| hook = knit_hooks$get('plot') | ||||||||
| hook(x, options) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| wrap.knit_embed_url = function(x, options = opts_chunk$get(), inline = FALSE) { | ||||||||
| options$fig.cur = plot_counter() | ||||||||
| options = reduce_plot_opts(options) | ||||||||
| if (length(extra <- options$out.extra)) extra = paste('', extra, collapse = '') | ||||||||
| add_html_caption(options, sprintf( | ||||||||
| '<iframe src="%s" width="%s" height="%s"%s></iframe>', | ||||||||
| escape_html(x$url), options$out.width %n% '100%', x$height %n% '400px', | ||||||||
| extra %n% '' | ||||||||
| )) | ||||||||
| } | ||||||||
| add_html_caption = function(options, code) { | ||||||||
| cap = .img.cap(options) | ||||||||
| if (cap == '') return(code) | ||||||||
| sprintf( | ||||||||
| '<div class="figure"%s>\n%s\n<p class="caption">%s</p>\n</div>', | ||||||||
| css_text_align(options$fig.align), code, cap | ||||||||
| ) | ||||||||
| } | ||||||||
| #' A custom printing function | ||||||||
| #' | ||||||||
| #' The S3 generic function \code{knit_print} is the default printing function in | ||||||||
| #' \pkg{knitr}. The chunk option \code{render} uses this function by default. | ||||||||
| #' The main purpose of this S3 generic function is to customize printing of R | ||||||||
| #' objects in code chunks. We can fall back to the normal printing behavior by | ||||||||
| #' setting the chunk option \code{render = normal_print}. | ||||||||
| #' | ||||||||
| #' Users can write custom methods based on this generic function. For example, | ||||||||
| #' if we want to print all data frames as tables in the output, we can define a | ||||||||
| #' method \code{knit_print.data.frame} that turns a data.frame into a table (the | ||||||||
| #' implementation may use other R packages or functions, e.g. \pkg{xtable} or | ||||||||
| #' \code{\link{kable}()}). | ||||||||
| #' @param x An R object to be printed | ||||||||
| #' @param ... Additional arguments passed to the S3 method. Currently ignored, | ||||||||
| #' except two optional arguments \code{options} and \code{inline}; see | ||||||||
| #' the references below. | ||||||||
| #' @return The value returned from the print method should be a character vector | ||||||||
| #' or can be converted to a character value. You can wrap the value in | ||||||||
| #' \code{\link{asis_output}()} so that \pkg{knitr} writes the character value | ||||||||
| #' as is in the output. | ||||||||
| #' @note It is recommended to leave a \code{...} argument in your method, to | ||||||||
| #' allow future changes of the \code{knit_print()} API without breaking your | ||||||||
| #' method. | ||||||||
| #' @references See \code{vignette('knit_print', package = 'knitr')}. | ||||||||
| #' @export | ||||||||
| #' @examples library(knitr) | ||||||||
| #' # write tables for data frames | ||||||||
| #' knit_print.data.frame = function(x, ...) { | ||||||||
| #' res = paste(c('', '', kable(x, output = FALSE)), collapse = '\n') | ||||||||
| #' asis_output(res) | ||||||||
| #' } | ||||||||
| #' # register the method | ||||||||
| #' registerS3method("knit_print", "data.frame", knit_print.data.frame) | ||||||||
| #' # after you define and register the above method, data frames will be printed | ||||||||
| #' # as tables in knitr, which is different with the default print() behavior | ||||||||
| knit_print = function(x, ...) { | ||||||||
| if (need_screenshot(x, ...)) { | ||||||||
| html_screenshot(x) | ||||||||
| } else { | ||||||||
| UseMethod('knit_print') | ||||||||
| } | ||||||||
| } | ||||||||
| #" the default print method is just print()/show() | ||||||||
| #' @export | ||||||||
| knit_print.default = function(x, ..., inline = FALSE) { | ||||||||
| if (inline) x else normal_print(x) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| knit_print.knit_asis = function(x, ...) x | ||||||||
| #' @rdname knit_print | ||||||||
| #' @export | ||||||||
| normal_print = default_handlers$value | ||||||||
| formals(normal_print) = alist(x = , ... = ) | ||||||||
| #' Mark an R object with a special class | ||||||||
| #' | ||||||||
| #' This is a convenience function that assigns the input object a class named | ||||||||
| #' \code{knit_asis}, so that \pkg{knitr} will treat it as is (the effect is the | ||||||||
| #' same as the chunk option \code{results = 'asis'}) when it is written to the | ||||||||
| #' output. | ||||||||
| #' | ||||||||
| #' This function is normally used in a custom S3 method based on the printing | ||||||||
| #' function \code{\link{knit_print}()}. | ||||||||
| #' | ||||||||
| #' For the \code{cacheable} argument, you need to be careful when printing the | ||||||||
| #' object involves non-trivial side effects, in which case it is strongly | ||||||||
| #' recommended to use \code{cacheable = FALSE} to instruct \pkg{knitr} that this | ||||||||
| #' object should not be cached using the chunk option \code{cache = TRUE}, | ||||||||
| #' otherwise the side effects will be lost the next time the chunk is knitted. | ||||||||
| #' For example, printing a \pkg{shiny} input element or an HTML widget in an R | ||||||||
| #' Markdown document may involve registering metadata about some JavaScript | ||||||||
| #' libraries or stylesheets, and the metadata may be lost if we cache the code | ||||||||
| #' chunk, because the code evaluation will be skipped the next time. This | ||||||||
| #' particular issue has been solved in \pkg{knitr} after v1.13 (the metadata | ||||||||
| #' will be saved and loaded automatically when caching is enabled), but not all | ||||||||
| #' metadata can be saved and loaded next time and still works in the new R | ||||||||
| #' session. | ||||||||
| #' @param x An R object. Typically a character string, or an object which can | ||||||||
| #' be converted to a character string via \code{\link{as.character}()}. | ||||||||
| #' @param meta Additional metadata of the object to be printed. The metadata | ||||||||
| #' will be collected when the object is printed, and accessible via | ||||||||
| #' \code{knit_meta()}. | ||||||||
| #' @param cacheable Boolean indicating whether this object is cacheable. If | ||||||||
| #' \code{FALSE}, \pkg{knitr} will stop when caching is enabled on code chunks | ||||||||
| #' that contain \code{asis_output()}. | ||||||||
| #' @note This function only works in top-level R expressions, and it will not | ||||||||
| #' work when it is called inside another expression, such as a for-loop. See | ||||||||
| #' \url{https://github.com/yihui/knitr/issues/1137} for a discussion. | ||||||||
| #' @export | ||||||||
| #' @examples # see ?knit_print | ||||||||
| asis_output = function(x, meta = NULL, cacheable = NA) { | ||||||||
| structure(x, class = 'knit_asis', knit_meta = meta, knit_cacheable = cacheable) | ||||||||
| } | ||||||||
| #' Metadata about objects to be printed | ||||||||
| #' | ||||||||
| #' As an object is printed, \pkg{knitr} will collect metadata about it (if | ||||||||
| #' available). After knitting is done, all the metadata is accessible via this | ||||||||
| #' function. You can manually add metadata to the \pkg{knitr} session via | ||||||||
| #' \code{knit_meta_add()}. | ||||||||
| #' @param class Optionally return only metadata entries that inherit from the | ||||||||
| #' specified class. The default, \code{NULL}, returns all entries. | ||||||||
| #' @param clean Whether to clean the collected metadata. By default, the | ||||||||
| #' metadata stored in \pkg{knitr} is cleaned up once retrieved, because we may | ||||||||
| #' not want the metadata to be passed to the next \code{knit()} call; to be | ||||||||
| #' defensive (i.e. not to have carryover metadata), you can call | ||||||||
| #' \code{knit_meta()} before \code{knit()}. | ||||||||
| #' @export | ||||||||
| #' @return \code{knit_meta()} returns the matched metadata specified by | ||||||||
| #' \code{class}; \code{knit_meta_add()} returns all current metadata. | ||||||||
| knit_meta = function(class = NULL, clean = TRUE) { | ||||||||
| if (is.null(class)) { | ||||||||
| if (clean) on.exit({.knitEnv$meta = list()}, add = TRUE) | ||||||||
| return(.knitEnv$meta) | ||||||||
| } | ||||||||
| # if a class was specified, match the items belonging to the class | ||||||||
| matches = if (length(.knitEnv$meta)) { | ||||||||
| vapply(.knitEnv$meta, inherits, logical(1), what = class) | ||||||||
| } | ||||||||
| if (!any(matches)) return(list()) | ||||||||
| if (clean) on.exit({ | ||||||||
| .knitEnv$meta[matches] = NULL | ||||||||
| id = attr(.knitEnv$meta, 'knit_meta_id') | ||||||||
| if (length(id)) attr(.knitEnv$meta, 'knit_meta_id') = id[!matches] | ||||||||
| }, add = TRUE) | ||||||||
| .knitEnv$meta[matches] | ||||||||
| } | ||||||||
| #' @param meta A metadata object to be added to the session. | ||||||||
| #' @param label A chunk label to indicate which chunk the metadata belongs to. | ||||||||
| #' @rdname knit_meta | ||||||||
| #' @export | ||||||||
| knit_meta_add = function(meta, label = '') { | ||||||||
| if (length(meta)) { | ||||||||
| meta_id = attr(.knitEnv$meta, 'knit_meta_id') | ||||||||
| .knitEnv$meta = c(.knitEnv$meta, meta) | ||||||||
| attr(.knitEnv$meta, 'knit_meta_id') = c(meta_id, rep_len(label, length(meta))) | ||||||||
| } | ||||||||
| .knitEnv$meta | ||||||||
| } | ||||||||
| rmarkdown/R/render.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' R Markdown Metadata | ||||||||
| #' | ||||||||
| #' Rmd files include a metadata section (typically located at the top of the | ||||||||
| #' file) that can specify (among other things) the title, author, and date of | ||||||||
| #' the document. Metadata adheres to the \href{https://yaml.org}{YAML} format | ||||||||
| #' and is delimited by lines containing three dashes (\code{---}). Here is an | ||||||||
| #' example metadata section: | ||||||||
| #' \preformatted{--- | ||||||||
| #' title: "Crop Analysis Q3 2013" | ||||||||
| #' author: Martha Smith | ||||||||
| #' date: October 23rd, 2013 | ||||||||
| #' --- | ||||||||
| #' } | ||||||||
| #' Note that the \code{title} field is quoted. This is because titles often | ||||||||
| #' contained embedded colons (\code{:}) and colons followed by a space need to | ||||||||
| #' be quoted in YAML. | ||||||||
| #' @details When title, author, and date metadata is provided it's used to | ||||||||
| #' automatically create a title section within output documents. If you don't | ||||||||
| #' want this section included in your document then you should remove the | ||||||||
| #' corresponding metadata fields. | ||||||||
| #' | ||||||||
| #' When generating PDF and Beamer output there are also a number of other | ||||||||
| #' metadata fields that can be included to customize the appearance and theme | ||||||||
| #' of PDF output. For more details see the documentation for | ||||||||
| #' \code{\link{pdf_document}} and \code{\link{beamer_presentation}}. | ||||||||
| #' @name rmd_metadata | ||||||||
| NULL | ||||||||
| #' The YAML metadata of the current R Markdown document | ||||||||
| #' | ||||||||
| #' The object \code{metadata} stores the YAML metadata of the current R Markdown | ||||||||
| #' document as a list, which you may use in the R code chunks, e.g. | ||||||||
| #' \code{rmarkdown::metadata$title} (the title of the document), | ||||||||
| #' \code{rmarkdown::metadata$author}, and \code{rmarkdown::metadata$foo} (if you | ||||||||
| #' have a YAML field named \code{foo}), etc. | ||||||||
| #' @usage NULL | ||||||||
| #' @examples rmarkdown::metadata | ||||||||
| #' @export | ||||||||
| metadata <- list() | ||||||||
| #' Compiling R scripts to a notebook | ||||||||
| #' | ||||||||
| #' R Markdown can also compile R scripts to a notebook which includes | ||||||||
| #' commentary, source code, and script output. Notebooks can be compiled to any | ||||||||
| #' output format including HTML, PDF, and MS Word. | ||||||||
| #' | ||||||||
| #' @section Overview: | ||||||||
| #' To compile a notebook from an R script you simply pass the script to | ||||||||
| #' \code{\link{render}}. For example: | ||||||||
| #' \preformatted{ | ||||||||
| #' rmarkdown::render("analysis.R") | ||||||||
| #' rmarkdown::render("analysis.R", "pdf_document") | ||||||||
| #' } | ||||||||
| #' The first call to \code{\link{render}} creates an HTML document, whereas | ||||||||
| #' the second creates a PDF document. | ||||||||
| #' | ||||||||
| #' By default the name of the script, username, and current date and time are | ||||||||
| #' included in the header of the generated notebook. You can override this | ||||||||
| #' default behavior by including explicit metadata in a specially formatted R | ||||||||
| #' comment: | ||||||||
| #' \preformatted{ | ||||||||
| #' #' --- | ||||||||
| #' #' title: "Crop Analysis Q3 2013" | ||||||||
| #' #' author: "John Smith" | ||||||||
| #' #' date: "May 3rd, 2014" | ||||||||
| #' #' --- | ||||||||
| #' } | ||||||||
| #' @section Including Markdown: | ||||||||
| #' Note that the R comment used above to add a title, author, and date | ||||||||
| #' includes a single-quote as a special prefix character. This is a | ||||||||
| #' \pkg{roxygen2} style comment, and it's actually possible to include many | ||||||||
| #' such comments in an R script, all of which will be converted to markdown | ||||||||
| #' content within the generated notebook. For example: | ||||||||
| #' \preformatted{#' A script comment that includes **markdown** formatting.} | ||||||||
| #' Rather than displaying as an R comment in the compiled notebook any | ||||||||
| #' \pkg{roxygen2} style comment will be treated as markdown and rendered | ||||||||
| #' accordingly. | ||||||||
| #' @section knitr Spin: | ||||||||
| #' Including markdown within R comments is possible because \code{\link{render}} | ||||||||
| #' calls the \code{\link[knitr:spin]{knitr spin}} function to convert the R | ||||||||
| #' script to an Rmd file. The \code{spin} function also enables you to add | ||||||||
| #' knitr | ||||||||
| #' chunk options with another special comment prefix (\code{#+}). | ||||||||
| #' | ||||||||
| #' Here's an example of a script that uses the various features of \code{spin}: | ||||||||
| #' | ||||||||
| #' \url{https://github.com/yihui/knitr/blob/master/inst/examples/knitr-spin.R} | ||||||||
| #' | ||||||||
| #' For more details on \code{knitr::spin} see the following documentation: | ||||||||
| #' | ||||||||
| #' \url{https://yihui.org/knitr/demo/stitch/} | ||||||||
| #' @name compile_notebook | ||||||||
| NULL | ||||||||
| #' Render R Markdown | ||||||||
| #' | ||||||||
| #' Render the input file to the specified output format using pandoc. If the | ||||||||
| #' input requires knitting then \code{\link[knitr:knit]{knit}} is called prior | ||||||||
| #' to pandoc. | ||||||||
| #' | ||||||||
| #' Note that the \pkg{knitr} \code{error} option is set to \code{FALSE} during | ||||||||
| #' rendering (which is different from the \pkg{knitr} default value of | ||||||||
| #' \code{TRUE}). | ||||||||
| #' | ||||||||
| #' For additional details on rendering R scripts see | ||||||||
| #' \link[=compile_notebook]{Compiling R scripts to a notebook}. | ||||||||
| #' | ||||||||
| #' If no \code{output_format} parameter is specified then the output format is | ||||||||
| #' read from the YAML front-matter of the input file. For example, the | ||||||||
| #' following YAML would yield a PDF document: | ||||||||
| #' | ||||||||
| #' \preformatted{ | ||||||||
| #' output: pdf_document | ||||||||
| #' } | ||||||||
| #' | ||||||||
| #' Additional format options can also be specified in metadata. For example: | ||||||||
| #' | ||||||||
| #' \preformatted{ | ||||||||
| #' output: | ||||||||
| #' pdf_document: | ||||||||
| #' toc: true | ||||||||
| #' highlight: zenburn | ||||||||
| #' } | ||||||||
| #' | ||||||||
| #' Multiple formats can be specified in metadata. If no \code{output_format} | ||||||||
| #' is passed to \code{render} then the first one defined will be used: | ||||||||
| #' | ||||||||
| #' \preformatted{ | ||||||||
| #' output: | ||||||||
| #' pdf_document: | ||||||||
| #' toc: true | ||||||||
| #' highlight: zenburn | ||||||||
| #' html_document: | ||||||||
| #' toc: true | ||||||||
| #' theme: united | ||||||||
| #' } | ||||||||
| #' | ||||||||
| #' Formats specified in metadata can be any one of the built in formats (e.g. | ||||||||
| #' \code{\link{html_document}}, \code{\link{pdf_document}}) or a format defined | ||||||||
| #' in another package (e.g. \code{pkg::custom_format}). | ||||||||
| #' | ||||||||
| #' If there is no format defined in the YAML then | ||||||||
| #' \code{\link{html_document}} will be used. | ||||||||
| #' @section R Markdown: | ||||||||
| #' R Markdown supports all of the base pandoc markdown features as well as some | ||||||||
| #' optional features for compatibility with GitHub Flavored Markdown (which | ||||||||
| #' previous versions of R Markdown were based on). See | ||||||||
| #' \code{\link{rmarkdown_format}} for details. | ||||||||
| #' @seealso | ||||||||
| #' \link[knitr:knit]{knit}, \link{output_format}, | ||||||||
| #' \url{https://pandoc.org} | ||||||||
| #' @inheritParams default_output_format | ||||||||
| #' @param input The input file to be rendered. This can be an R script (.R), | ||||||||
| #' an R Markdown document (.Rmd), or a plain markdown document. | ||||||||
| #' @param output_format The R Markdown output format to convert to. The option | ||||||||
| #' \code{"all"} will render all formats defined within the file. The option can | ||||||||
| #' be the name of a format (e.g. \code{"html_document"}) and that will render | ||||||||
| #' the document to that single format. One can also use a vector of format | ||||||||
| #' names to render to multiple formats. Alternatively, you can pass an output | ||||||||
| #' format object (e.g. \code{html_document()}). If using \code{NULL} then the | ||||||||
| #' output format is the first one defined in the YAML frontmatter in the input | ||||||||
| #' file (this defaults to HTML if no format is specified there). | ||||||||
| #' If you pass an output format object to \code{output_format}, the options | ||||||||
| #' specified in the YAML header or \code{_output.yml} will be ignored and you | ||||||||
| #' must explicitly set all the options you want when you construct the object. | ||||||||
| #' If you pass a string, the output format will use the output parameters in | ||||||||
| #' the YAML header or \code{_output.yml}. | ||||||||
| #' @param output_file The name of the output file. If using \code{NULL} then the | ||||||||
| #' output filename will be based on filename for the input file. If a filename | ||||||||
| #' is provided, a path to the output file can also be provided. Note that the | ||||||||
| #' \code{output_dir} option allows for specifying the output file path as well, | ||||||||
| #' however, if also specifying the path, the directory must exist. If | ||||||||
| #' \code{output_file} is specified but does not have a file extension, an | ||||||||
| #' extension will be automatically added according to the output format. To | ||||||||
| #' avoid the automatic file extension, put the \code{output_file} value in | ||||||||
| #' \code{\link{I}()}, e.g., \code{I('my-output')}. | ||||||||
| #' @param output_dir The output directory for the rendered \code{output_file}. | ||||||||
| #' This allows for a choice of an alternate directory to which the output file | ||||||||
| #' should be written (the default output directory of that of the input file). | ||||||||
| #' If a path is provided with a filename in \code{output_file} the directory | ||||||||
| #' specified here will take precedence. Please note that any directory path | ||||||||
| #' provided will create any necessary directories if they do not exist. | ||||||||
| #' @param output_options List of output options that can override the options | ||||||||
| #' specified in metadata (e.g. could be used to force \code{self_contained} or | ||||||||
| #' \code{mathjax = "local"}). Note that this is only valid when the output | ||||||||
| #' format is read from metadata (i.e. not a custom format object passed to | ||||||||
| #' \code{output_format}). | ||||||||
| #' @param intermediates_dir Intermediate files directory. If a path is specified | ||||||||
| #' then intermediate files will be written to that path. If \code{NULL}, | ||||||||
| #' intermediate files are written to the same directory as the input file. | ||||||||
| #' @param knit_root_dir The working directory in which to knit the document; | ||||||||
| #' uses knitr's \code{root.dir} knit option. If \code{NULL} then the behavior | ||||||||
| #' will follow the knitr default, which is to use the parent directory of the | ||||||||
| #' document. | ||||||||
| #' @param runtime The runtime target for rendering. The \code{static} option | ||||||||
| #' produces output intended for static files; \code{shiny} produces output | ||||||||
| #' suitable for use in a Shiny document (see \code{\link{run}}). The default, | ||||||||
| #' \code{auto}, allows the \code{runtime} target specified in the YAML metadata | ||||||||
| #' to take precedence, and renders for a \code{static} runtime target otherwise. | ||||||||
| #' @param clean Using \code{TRUE} will clean intermediate files that are created | ||||||||
| #' during rendering. | ||||||||
| #' @param params A list of named parameters that override custom params | ||||||||
| #' specified within the YAML front-matter (e.g. specifying a dataset to read or | ||||||||
| #' a date range to confine output to). Pass \code{"ask"} to start an | ||||||||
| #' application that helps guide parameter configuration. | ||||||||
| #' @param knit_meta (This option is reserved for expert use.) Metadata | ||||||||
| #' generated by \pkg{knitr}. | ||||||||
| #' @param envir The environment in which the code chunks are to be evaluated | ||||||||
| #' during knitting (can use \code{\link{new.env}()} to guarantee an empty new | ||||||||
| #' environment). | ||||||||
| #' @param run_pandoc An option for whether to run pandoc to convert Markdown | ||||||||
| #' output. | ||||||||
| #' @param quiet An option to suppress printing of the pandoc command line. | ||||||||
| #' @param encoding Ignored. The encoding is always assumed to be UTF-8. | ||||||||
| #' @return | ||||||||
| #' When \code{run_pandoc = TRUE}, the compiled document is written into | ||||||||
| #' the output file, and the path of the output file is returned. When | ||||||||
| #' \code{run_pandoc = FALSE}, the path of the Markdown output file, with | ||||||||
| #' attributes \code{knit_meta} (the \pkg{knitr} meta data collected from code | ||||||||
| #' chunks) and \code{intermediates} (the intermediate files/directories | ||||||||
| #' generated by \code{render()}). | ||||||||
| #' @examples | ||||||||
| #' \dontrun{ | ||||||||
| #' library(rmarkdown) | ||||||||
| #' | ||||||||
| #' # Render the default (first) format defined in the file | ||||||||
| #' render("input.Rmd") | ||||||||
| #' | ||||||||
| #' # Render all formats defined in the file | ||||||||
| #' render("input.Rmd", "all") | ||||||||
| #' | ||||||||
| #' # Render a single format, using parameters for \code{html_document} from | ||||||||
| #' # the YAML header parameters. | ||||||||
| #' render("input.Rmd", "html_document") | ||||||||
| #' | ||||||||
| #' # Render a single format, ignoring parameters for \code{html_document} in | ||||||||
| #' # the YAML header. Any parameters not passed as arguments to | ||||||||
| #' # \code{html_document()} will be assigned to their default values, regardless | ||||||||
| #' # of anything in the YAML header | ||||||||
| #' render("input.Rmd", html_document(toc = TRUE, toc_depth = 2)) | ||||||||
| #' | ||||||||
| #' # Render multiple formats | ||||||||
| #' render("input.Rmd", c("html_document", "pdf_document")) | ||||||||
| #' } | ||||||||
| #' @export | ||||||||
| render <- function(input, | ||||||||
| output_format = NULL, | ||||||||
| output_file = NULL, | ||||||||
| output_dir = NULL, | ||||||||
| output_options = NULL, | ||||||||
| output_yaml = NULL, | ||||||||
| intermediates_dir = NULL, | ||||||||
| knit_root_dir = NULL, | ||||||||
| runtime = c("auto", "static", "shiny", "shinyrmd", "shiny_prerendered"), | ||||||||
| clean = TRUE, | ||||||||
| params = NULL, | ||||||||
| knit_meta = NULL, | ||||||||
| envir = parent.frame(), | ||||||||
| run_pandoc = TRUE, | ||||||||
| quiet = FALSE, | ||||||||
| encoding = "UTF-8") { | ||||||||
| perf_timer_start("render") | ||||||||
| init_render_context() | ||||||||
| on.exit(clear_render_context(), add = TRUE) | ||||||||
| # render() may call itself, e.g., in discover_rmd_resources(); in this case, | ||||||||
| # we should not clean up temp files in the nested render() call, but wait | ||||||||
| # until the top-level render() exits to clean up temp files | ||||||||
| .globals$level <- .globals$level + 1L # increment level in a nested render() | ||||||||
| on.exit({ | ||||||||
| .globals$level <- .globals$level - 1L | ||||||||
| if (.globals$level == 0) clean_tmpfiles() | ||||||||
| }, add = TRUE) | ||||||||
| # check for "all" output formats | ||||||||
| if (identical(output_format, "all")) { | ||||||||
| output_format <- enumerate_output_formats(input) | ||||||||
| if (is.null(output_format)) | ||||||||
| output_format <- "html_document" | ||||||||
| } | ||||||||
| # check for a list of output formats -- if there is more than one | ||||||||
| # then recursively call this function with each format by name | ||||||||
| if (is.character(output_format) && length(output_format) > 1) { | ||||||||
| outputs <- character() | ||||||||
| for (i in seq_along(output_format)) { | ||||||||
| # the output_file argument is intentionally ignored (we can't give | ||||||||
| # the same name to each rendered output); copy the rest by name | ||||||||
| output <- render(input = input, | ||||||||
| output_format = output_format[i], | ||||||||
| output_file = output_file[i], | ||||||||
| output_dir = output_dir, | ||||||||
| output_options = output_options, | ||||||||
| intermediates_dir = intermediates_dir, | ||||||||
| knit_root_dir = knit_root_dir, | ||||||||
| runtime = runtime, | ||||||||
| clean = clean, | ||||||||
| params = params, | ||||||||
| knit_meta = knit_meta, | ||||||||
| envir = envir, | ||||||||
| run_pandoc = run_pandoc, | ||||||||
| quiet = quiet) | ||||||||
| outputs <- c(outputs, output) | ||||||||
| } | ||||||||
| return(invisible(outputs)) | ||||||||
| } | ||||||||
| # check for required version of pandoc if we are running pandoc | ||||||||
| if (run_pandoc) { | ||||||||
| required_pandoc <- "1.12.3" | ||||||||
| pandoc_available(required_pandoc, error = TRUE) | ||||||||
| } | ||||||||
| # setup a cleanup function for intermediate files | ||||||||
| intermediates <- c() | ||||||||
| on.exit(if (clean) unlink(intermediates, recursive = TRUE), add = TRUE) | ||||||||
| # ensure we have a directory to store intermediates | ||||||||
| if (!is.null(intermediates_dir)) { | ||||||||
| if (!dir_exists(intermediates_dir)) | ||||||||
| dir.create(intermediates_dir, recursive = TRUE) | ||||||||
| intermediates_dir <- normalize_path(intermediates_dir) | ||||||||
| } | ||||||||
| intermediates_loc <- function(file) { | ||||||||
| if (is.null(intermediates_dir)) | ||||||||
| file | ||||||||
| else | ||||||||
| file.path(intermediates_dir, file) | ||||||||
| } | ||||||||
| # resolve output directory before we change the working directory in | ||||||||
| # preparation for rendering the document | ||||||||
| if (!is.null(output_dir)) { | ||||||||
| if (!dir_exists(output_dir)) | ||||||||
| dir.create(output_dir, recursive = TRUE) | ||||||||
| output_dir <- normalize_path(output_dir) | ||||||||
| } | ||||||||
| # check whether this document requires a knit | ||||||||
| requires_knit <- tolower(xfun::file_ext(input)) %in% c("r", "rmd", "rmarkdown") | ||||||||
| # remember the name of the original input document (we overwrite 'input' once | ||||||||
| # we've knitted) | ||||||||
| original_input <- normalize_path(input) | ||||||||
| # if the input file has shell characters in its name then make a copy that | ||||||||
| # doesn't have shell characters | ||||||||
| if (grepl(.shell_chars_regex, basename(input))) { | ||||||||
| # form the name of the file w/o shell characters | ||||||||
| input_no_shell_chars <- intermediates_loc( | ||||||||
| file_name_without_shell_chars(basename(input))) | ||||||||
| if (file.exists(input_no_shell_chars)) { | ||||||||
| stop("The name of the input file cannot contain the special shell ", | ||||||||
| "characters: ", .shell_chars_regex, " (attempted to copy to a ", | ||||||||
| "version without those characters '", input_no_shell_chars, "' ", | ||||||||
| "however that file already exists)", call. = FALSE) | ||||||||
| } | ||||||||
| file.copy(input, input_no_shell_chars, overwrite = TRUE) | ||||||||
| intermediates <- c(intermediates, input_no_shell_chars) | ||||||||
| input <- input_no_shell_chars | ||||||||
| # if an intermediates directory wasn't explicit before, make it explicit now | ||||||||
| if (is.null(intermediates_dir)) { | ||||||||
| intermediates_dir <- | ||||||||
| dirname(normalize_path(input_no_shell_chars)) | ||||||||
| } | ||||||||
| } | ||||||||
| # never use the original input directory as the intermediate directory, | ||||||||
| # otherwise external resources discovered will be deleted as intermediate | ||||||||
| # files later (because they are copied to the "intermediate" dir) | ||||||||
| if (!is.null(intermediates_dir) && | ||||||||
| same_path(intermediates_dir, dirname(original_input))) | ||||||||
| intermediates_dir <- NULL | ||||||||
| # force evaluation of knitr root dir before we change directory context | ||||||||
| force(knit_root_dir) | ||||||||
| # execute within the input file's directory | ||||||||
| oldwd <- setwd(dirname(abs_path(input))) | ||||||||
| on.exit(setwd(oldwd), add = TRUE) | ||||||||
| # reset the name of the input file to be relative and calculate variations | ||||||||
| # on the filename for our various intermediate targets | ||||||||
| input <- basename(input) | ||||||||
| knit_input <- input | ||||||||
| knit_output <- intermediates_loc(file_with_meta_ext(input, "knit", "md")) | ||||||||
| intermediates <- c(intermediates, knit_output) | ||||||||
| utf8_input <- intermediates_loc(file_with_meta_ext(input, "utf8", "md")) | ||||||||
| intermediates <- c(intermediates, utf8_input) | ||||||||
| # track whether this was straight markdown input (to prevent keep_md later) | ||||||||
| md_input <- identical(tolower(xfun::file_ext(input)), "md") | ||||||||
| # if this is an R script then spin it first | ||||||||
| if (identical(tolower(xfun::file_ext(input)), "r")) { | ||||||||
| # make a copy of the file to spin | ||||||||
| spin_input <- intermediates_loc(file_with_meta_ext(input, "spin", "R")) | ||||||||
| file.copy(input, spin_input, overwrite = TRUE) | ||||||||
| intermediates <- c(intermediates, spin_input) | ||||||||
| # spin it | ||||||||
| spin_rmd <- knitr::spin(spin_input, | ||||||||
| knit = FALSE, | ||||||||
| envir = envir, | ||||||||
| format = "Rmd") | ||||||||
| intermediates <- c(intermediates, spin_rmd) | ||||||||
| knit_input <- spin_rmd | ||||||||
| # append default metadata unless the field exists in YAML | ||||||||
| meta1 <- yaml_front_matter(knit_input) | ||||||||
| meta2 <- list( | ||||||||
| title = input, author = Sys.info()[["user"]], | ||||||||
| date = as.character(Sys.Date()) | ||||||||
| ) | ||||||||
| for (i in names(meta2)) if (!is.null(meta1[[i]])) meta2[[i]] <- NULL | ||||||||
| if (length(meta2)) { | ||||||||
| input_lines <- read_utf8(knit_input) | ||||||||
| write_utf8(c(input_lines, '\n\n---', yaml::as.yaml(meta2), '---'), knit_input) | ||||||||
| } | ||||||||
| } | ||||||||
| # read the input file | ||||||||
| input_lines <- read_utf8(knit_input) | ||||||||
| # read the yaml front matter | ||||||||
| front_matter <- parse_yaml_front_matter(input_lines) | ||||||||
| # metadata to be attached to the returned value of render() as an attribute | ||||||||
| old_output_metadata <- output_metadata$get() | ||||||||
| on.exit(output_metadata$restore(old_output_metadata), add = TRUE) | ||||||||
| output_metadata$restore(as.list(front_matter[['rmd_output_metadata']])) | ||||||||
| # if this is shiny_prerendered then modify the output format to | ||||||||
| # be single-page and to output dependencies to the shiny.dep file | ||||||||
| shiny_prerendered_dependencies <- list() | ||||||||
| if (requires_knit && is_shiny_prerendered(front_matter$runtime)) { | ||||||||
| # require shiny for the knit | ||||||||
| if (requireNamespace("shiny")) { | ||||||||
| if (!"package:shiny" %in% search()) | ||||||||
| attachNamespace("shiny") | ||||||||
| } | ||||||||
| else | ||||||||
| stop("The shiny package is required for shinyrmd documents") | ||||||||
| # source global.R if it exists | ||||||||
| global_r <- file.path.ci(".", "global.R") | ||||||||
| if (file.exists(global_r)) { | ||||||||
| source(global_r, local = envir) | ||||||||
| } | ||||||||
| # force various output options | ||||||||
| output_options$self_contained <- FALSE | ||||||||
| output_options$dependency_resolver <- function(deps) { | ||||||||
| shiny_prerendered_dependencies <<- list( | ||||||||
| deps = deps, | ||||||||
| packages = get_loaded_packages() | ||||||||
| ) | ||||||||
| list() | ||||||||
| } | ||||||||
| } | ||||||||
| # if we haven't been passed a fully formed output format then | ||||||||
| # resolve it by looking at the yaml | ||||||||
| if (!is_output_format(output_format)) { | ||||||||
| output_format <- output_format_from_yaml_front_matter(input_lines, | ||||||||
| output_options, | ||||||||
| output_format, | ||||||||
| output_yaml) | ||||||||
| output_format <- create_output_format(output_format$name, | ||||||||
| output_format$options) | ||||||||
| } | ||||||||
| pandoc_to <- output_format$pandoc$to | ||||||||
| # generate outpout file based on input filename | ||||||||
| output_auto <- pandoc_output_file(input, output_format$pandoc) | ||||||||
| if (is.null(output_file) || is.na(output_file)) output_file <- output_auto else { | ||||||||
| if (!inherits(output_file, "AsIs") && xfun::file_ext(output_file) == "") | ||||||||
| output_file <- paste(output_file, xfun::file_ext(output_auto), sep = ".") | ||||||||
| } | ||||||||
| # if an output_dir was specified then concatenate it with the output file | ||||||||
| if (!is.null(output_dir)) { | ||||||||
| output_file <- file.path(output_dir, basename(output_file)) | ||||||||
| } | ||||||||
| output_dir <- dirname(output_file) | ||||||||
| # Stop the render process early if the output directory does not exist | ||||||||
| if (!dir_exists(output_dir)) { | ||||||||
| stop("The directory '", output_dir, "' does not not exist.", | ||||||||
| call. = FALSE) | ||||||||
| } | ||||||||
| # use output filename based files dir | ||||||||
| files_dir_slash <- file.path(output_dir, knitr_files_dir(basename(output_file))) | ||||||||
| files_dir <- pandoc_path_arg(files_dir_slash) | ||||||||
| # default to no cache_dir (may be generated by the knit) | ||||||||
| cache_dir <- NULL | ||||||||
| # call any intermediate files generator, if we have an intermediates directory | ||||||||
| # (do this before knitting in case the knit requires intermediates) | ||||||||
| if (!is.null(intermediates_dir) && | ||||||||
| !is.null(output_format$intermediates_generator)) { | ||||||||
| intermediates <- c(intermediates, | ||||||||
| output_format$intermediates_generator(original_input, | ||||||||
| intermediates_dir)) | ||||||||
| } | ||||||||
| # reset knit_meta (and ensure it's always reset before exiting render) | ||||||||
| old_knit_meta <- knit_meta_reset() | ||||||||
| on.exit({ | ||||||||
| knit_meta_reset() | ||||||||
| if (length(old_knit_meta)) { | ||||||||
| knitr::knit_meta_add(old_knit_meta, attr(old_knit_meta, 'knit_meta_id')) | ||||||||
| } | ||||||||
| }, add = TRUE) | ||||||||
| # presume that we're rendering as a static document unless specified | ||||||||
| # otherwise in the parameters | ||||||||
| runtime <- match.arg(runtime) | ||||||||
| if (identical(runtime, "auto")) runtime <- front_matter$runtime %||% "static" | ||||||||
| # set df_print | ||||||||
| context <- render_context() | ||||||||
| context$df_print <- resolve_df_print(output_format$df_print) | ||||||||
| # make the front_matter available as 'metadata' within the knit environment | ||||||||
| # (unless it is already defined there, in which case we emit a warning) | ||||||||
| env <- environment(render) | ||||||||
| metadata_this <- env$metadata | ||||||||
| do.call("unlockBinding", list("metadata", env)) | ||||||||
| on.exit({ | ||||||||
| if (bindingIsLocked("metadata", env)) { | ||||||||
| do.call("unlockBinding", list("metadata", env)) | ||||||||
| } | ||||||||
| env$metadata <- metadata_this | ||||||||
| lockBinding("metadata", env) | ||||||||
| }, add = TRUE) | ||||||||
| env$metadata <- front_matter | ||||||||
| # call any pre_knit handler | ||||||||
| if (!is.null(output_format$pre_knit)) { | ||||||||
| output_format$pre_knit(input = original_input) | ||||||||
| } | ||||||||
| # function used to call post_knit handler | ||||||||
| call_post_knit_handler <- function() { | ||||||||
| if (!is.null(output_format$post_knit)) { | ||||||||
| post_knit_extra_args <- output_format$post_knit(front_matter, | ||||||||
| knit_input, | ||||||||
| runtime, | ||||||||
| encoding = 'UTF-8') | ||||||||
| } else { | ||||||||
| post_knit_extra_args <- NULL | ||||||||
| } | ||||||||
| c(output_format$pandoc$args, post_knit_extra_args) | ||||||||
| } | ||||||||
| # determine our id-prefix (add one if necessary for runtime: shiny) | ||||||||
| id_prefix <- id_prefix_from_args(output_format$pandoc$args) | ||||||||
| if (!nzchar(id_prefix) && is_shiny(runtime)) { | ||||||||
| id_prefix <- "section-" | ||||||||
| output_format$pandoc$args <- c(output_format$pandoc$args, rbind("--id-prefix", id_prefix)) | ||||||||
| } | ||||||||
| # knit if necessary | ||||||||
| if (requires_knit) { | ||||||||
| # restore options and hooks after knit | ||||||||
| optk <- knitr::opts_knit$get() | ||||||||
| on.exit(knitr::opts_knit$restore(optk), add = TRUE) | ||||||||
| optc <- knitr::opts_chunk$get() | ||||||||
| on.exit(knitr::opts_chunk$restore(optc), add = TRUE) | ||||||||
| hooks <- knitr::knit_hooks$get() | ||||||||
| on.exit(knitr::knit_hooks$restore(hooks), add = TRUE) | ||||||||
| ohooks <- knitr::opts_hooks$get() | ||||||||
| on.exit(knitr::opts_hooks$restore(ohooks), add = TRUE) | ||||||||
| templates <- knitr::opts_template$get() | ||||||||
| on.exit(knitr::opts_template$restore(templates), add = TRUE) | ||||||||
| # specify that htmltools::htmlPreserve should use the pandoc raw | ||||||||
| # attribute (e.g. ```{=html}) rather than preservation tokens when | ||||||||
| # pandoc >= v2.0. Note that this option will have the intended effect | ||||||||
| # only for versions of htmltools >= 0.5.0.9003. | ||||||||
| if (pandoc2.0() && packageVersion("htmltools") >= "0.5.0.9003") { | ||||||||
| prev <- getOption("htmltools.preserve.raw", default = NA) | ||||||||
| options(htmltools.preserve.raw = TRUE) | ||||||||
| if (!is.na(prev)) { | ||||||||
| on.exit(options(htmltools.preserve.raw = prev), add = TRUE) | ||||||||
| } | ||||||||
| } | ||||||||
| # run render on_exit (run after the knit hooks are saved so that | ||||||||
| # any hook restoration can take precedence) | ||||||||
| if (is.function(output_format$on_exit)) | ||||||||
| on.exit(output_format$on_exit(), add = TRUE) | ||||||||
| # default rendering and chunk options | ||||||||
| knitr::render_markdown() | ||||||||
| knitr::opts_chunk$set(tidy = FALSE, error = FALSE) | ||||||||
| # the retina option does not make sense to non-HTML output formats | ||||||||
| if (!grepl('[.]html$', output_file)) knitr::opts_chunk$set(fig.retina = NULL) | ||||||||
| # store info about the final output format in opts_knit | ||||||||
| knitr::opts_knit$set( | ||||||||
| rmarkdown.pandoc.from = output_format$pandoc$from, | ||||||||
| rmarkdown.pandoc.to = pandoc_to, | ||||||||
| rmarkdown.pandoc.args = output_format$pandoc$args, | ||||||||
| rmarkdown.pandoc.id_prefix = id_prefix, | ||||||||
| rmarkdown.keep_md = output_format$keep_md, | ||||||||
| rmarkdown.df_print = output_format$df_print, | ||||||||
| rmarkdown.version = 2, | ||||||||
| rmarkdown.runtime = runtime | ||||||||
| ) | ||||||||
| # read root directory from argument (has precedence) or front matter | ||||||||
| root_dir <- knit_root_dir | ||||||||
| if (is.null(root_dir)) | ||||||||
| root_dir <- front_matter$knit_root_dir | ||||||||
| if (!is.null(root_dir)) | ||||||||
| knitr::opts_knit$set(root.dir = root_dir) | ||||||||
| # use filename based figure and cache directories | ||||||||
| base_pandoc_to <- gsub('[-+].*', '', pandoc_to) | ||||||||
| if (base_pandoc_to == 'html4') base_pandoc_to <- 'html' | ||||||||
| knitr::opts_chunk$set(fig.path = paste0( | ||||||||
| pandoc_path_arg(files_dir_slash, backslash = FALSE), | ||||||||
| "/figure-", base_pandoc_to, "/" | ||||||||
| )) | ||||||||
| cache_dir <- knitr_cache_dir(input, base_pandoc_to) | ||||||||
| knitr::opts_chunk$set(cache.path = cache_dir) | ||||||||
| # strip the trailing slash from cache_dir so that file.exists() and unlink() | ||||||||
| # check on it later works on windows | ||||||||
| cache_dir <- gsub("/$", "", cache_dir) | ||||||||
| # merge user options and hooks | ||||||||
| if (!is.null(output_format$knitr)) { | ||||||||
| knitr::opts_knit$set(as.list(output_format$knitr$opts_knit)) | ||||||||
| knitr::opts_chunk$set(adjust_dev(as.list(output_format$knitr$opts_chunk))) | ||||||||
| knitr::opts_template$set(as.list(output_format$knitr$opts_template)) | ||||||||
| knitr::knit_hooks$set(as.list(output_format$knitr$knit_hooks)) | ||||||||
| knitr::opts_hooks$set(as.list(output_format$knitr$opts_hooks)) | ||||||||
| } | ||||||||
| # setting the runtime (static/shiny) type | ||||||||
| knitr::opts_knit$set(rmarkdown.runtime = runtime) | ||||||||
| # install evaluate hook for shiny_prerendred | ||||||||
| if (is_shiny_prerendered(runtime)) { | ||||||||
| # remove uncached .RData (will be recreated from context="data" chunks) | ||||||||
| shiny_prerendered_remove_uncached_data(original_input) | ||||||||
| # set the cache option hook and evaluate hook | ||||||||
| knitr::opts_hooks$set(label = shiny_prerendered_option_hook(original_input)) | ||||||||
| knitr::knit_hooks$set(evaluate = shiny_prerendered_evaluate_hook(original_input)) | ||||||||
| } | ||||||||
| # install global chunk handling for runtime: shiny (evaluate the 'global' | ||||||||
| # chunk only once, and in the global environment) | ||||||||
| if (is_shiny_classic(runtime) && !is.null(shiny::getDefaultReactiveDomain())) { | ||||||||
| # install evaluate hook to ensure that the 'global' chunk for this source | ||||||||
| # file is evaluated only once and is run outside of a user reactive domain | ||||||||
| knitr::knit_hooks$set(evaluate = function(code, envir, ...) { | ||||||||
| # check for 'global' chunk label | ||||||||
| if (identical(knitr::opts_current$get("label"), "global")) { | ||||||||
| # check list of previously evaludated global chunks | ||||||||
| code_string <- one_string(code) | ||||||||
| if (!code_string %in% .globals$evaluated_global_chunks) { | ||||||||
| # save it in our list of evaluated global chunks | ||||||||
| .globals$evaluated_global_chunks <- | ||||||||
| c(.globals$evaluated_global_chunks, code_string) | ||||||||
| # evaluate with no reactive domain to prevent any shiny code (e.g. | ||||||||
| # a reactive timer) from attaching to the current user session | ||||||||
| # (resulting in it's destruction when that session ends) | ||||||||
| shiny::withReactiveDomain(NULL, { | ||||||||
| evaluate::evaluate(code, envir = globalenv(), ...) | ||||||||
| }) | ||||||||
| } else { | ||||||||
| list() | ||||||||
| } | ||||||||
| # delegate to standard evaluate for everything else | ||||||||
| } else { | ||||||||
| evaluate::evaluate(code, envir, ...) | ||||||||
| } | ||||||||
| }) | ||||||||
| } | ||||||||
| # make the params available within the knit environment | ||||||||
| # (only do this if there are parameters in the front matter | ||||||||
| # so we don't require recent knitr for all users) | ||||||||
| if (!is.null(front_matter$params)) { | ||||||||
| params <- knit_params_get(input_lines, params) | ||||||||
| # bail if an object called 'params' exists in this environment, | ||||||||
| # and it seems to be an unrelated user-created object. store | ||||||||
| # references so we can restore them post-render | ||||||||
| hasParams <- exists("params", envir = envir, inherits = FALSE) | ||||||||
| envirParams <- NULL | ||||||||
| if (hasParams) { | ||||||||
| envirParams <- get("params", envir = envir, inherits = FALSE) | ||||||||
| isKnownParamsObject <- | ||||||||
| inherits(envirParams, "knit_param_list") || | ||||||||
| inherits(envirParams, "knit_param") | ||||||||
| if (!isKnownParamsObject) { | ||||||||
| stop("params object already exists in knit environment ", | ||||||||
| "so can't be overwritten by render params", call. = FALSE) | ||||||||
| } | ||||||||
| } | ||||||||
| # make the params available in the knit environment | ||||||||
| assign("params", params, envir = envir) | ||||||||
| lockBinding("params", envir) | ||||||||
| on.exit({ | ||||||||
| if (exists("params", envir = envir, inherits = FALSE)) { | ||||||||
| do.call("unlockBinding", list("params", envir)) | ||||||||
| if (hasParams) | ||||||||
| assign("params", envirParams, envir = envir) | ||||||||
| else | ||||||||
| remove("params", envir = envir) | ||||||||
| } | ||||||||
| }, add = TRUE) | ||||||||
| } | ||||||||
| # call onKnit hooks (normalize to list) | ||||||||
| sapply(as.list(getHook("rmarkdown.onKnit")), function(hook) { | ||||||||
| tryCatch(hook(input = original_input), error = function(e) NULL) | ||||||||
| }) | ||||||||
| on.exit({ | ||||||||
| sapply(as.list(getHook("rmarkdown.onKnitCompleted")), function(hook) { | ||||||||
| tryCatch(hook(input = original_input), error = function(e) NULL) | ||||||||
| }) | ||||||||
| }, add = TRUE) | ||||||||
| perf_timer_start("knitr") | ||||||||
| # perform the knit | ||||||||
| input <- knitr::knit(knit_input, | ||||||||
| knit_output, | ||||||||
| envir = envir, | ||||||||
| quiet = quiet) | ||||||||
| perf_timer_stop("knitr") | ||||||||
| front_matter <- yaml_front_matter(input) | ||||||||
| # call post_knit handler | ||||||||
| output_format$pandoc$args <- call_post_knit_handler() | ||||||||
| # pull any R Markdown warnings from knit_meta and emit | ||||||||
| rmd_warnings <- knit_meta_reset(class = "rmd_warning") | ||||||||
| for (rmd_warning in rmd_warnings) { | ||||||||
| message("Warning: ", rmd_warning) | ||||||||
| } | ||||||||
| # pull out shiny_prerendered_contexts and append them as script tags | ||||||||
| shiny_prerendered_append_contexts(runtime, input) | ||||||||
| # collect remaining knit_meta | ||||||||
| knit_meta <- knit_meta_reset() | ||||||||
| } else { | ||||||||
| output_format$pandoc$args <- call_post_knit_handler() | ||||||||
| } | ||||||||
| # if this isn't html and there are html dependencies then flag an error | ||||||||
| if (!(is_pandoc_to_html(output_format$pandoc) || | ||||||||
| identical(tolower(xfun::file_ext(output_file)), "html"))) { | ||||||||
| if (has_html_dependencies(knit_meta)) { | ||||||||
| if (!isTRUE(front_matter$always_allow_html)) { | ||||||||
| stop("Functions that produce HTML output found in document targeting ", | ||||||||
| pandoc_to, " output.\nPlease change the output type ", | ||||||||
| "of this document to HTML. Alternatively, you can allow\n", | ||||||||
| "HTML output in non-HTML formats by adding this option to the YAML front", | ||||||||
| "-matter of\nyour rmarkdown file:\n\n", | ||||||||
| " always_allow_html: true\n\n", | ||||||||
| "Note however that the HTML output will not be visible in non-HTML formats.\n\n", | ||||||||
| call. = FALSE) | ||||||||
| } | ||||||||
| } | ||||||||
| if (!identical(runtime, "static")) { | ||||||||
| stop("Runtime '", runtime, "' is not supported for ", | ||||||||
| pandoc_to, " output.\nPlease change the output type ", | ||||||||
| "of this document to HTML.", call. = FALSE) | ||||||||
| } | ||||||||
| } | ||||||||
| # clean the files_dir if we've either been asking to clean supporting files or | ||||||||
| # the knitr cache is active; clean the figure-* dir instead of the whole | ||||||||
| # files_dir if other subdirs are generated by another format and still needed: | ||||||||
| # https://github.com/rstudio/rmarkdown/issues/1472 and also #1503 | ||||||||
| intermediates_fig <- if (output_format$clean_supporting && !dir_exists(cache_dir)) { | ||||||||
| # unlink does not support / at the end of file path | ||||||||
| fig_path <- gsub("/$", "", knitr::opts_chunk$get('fig.path')) | ||||||||
| # existing figure folder(s), can be character(0) | ||||||||
| # if no figure is generated, clean the whole files_dir (#1664) | ||||||||
| files_dir_fig <- list.files(files_dir, '^figure-.+') | ||||||||
| if (length(files_dir_fig) < 1 || identical(files_dir_fig, basename(fig_path))) { | ||||||||
| files_dir | ||||||||
| } else { | ||||||||
| fig_path | ||||||||
| } | ||||||||
| } | ||||||||
| intermediates <- c(intermediates, intermediates_fig) | ||||||||
| file.copy(input, utf8_input, overwrite = TRUE) | ||||||||
| if (run_pandoc) { | ||||||||
| perf_timer_start("pre-processor") | ||||||||
| # call any pre_processor | ||||||||
| if (!is.null(output_format$pre_processor)) { | ||||||||
| extra_args <- output_format$pre_processor(front_matter, | ||||||||
| utf8_input, | ||||||||
| runtime, | ||||||||
| knit_meta, | ||||||||
| files_dir, | ||||||||
| output_dir) | ||||||||
| output_format$pandoc$args <- c(output_format$pandoc$args, extra_args) | ||||||||
| } | ||||||||
| # write shiny_prerendered_dependencies if we have them | ||||||||
| if (is_shiny_prerendered(runtime)) { | ||||||||
| shiny_prerendered_append_dependencies(utf8_input, | ||||||||
| shiny_prerendered_dependencies, | ||||||||
| files_dir, | ||||||||
| output_dir) | ||||||||
| } | ||||||||
| perf_timer_stop("pre-processor") | ||||||||
| need_bibtex <- grepl('[.](pdf|tex)$', output_file) && | ||||||||
| any(c('--natbib', '--biblatex') %in% output_format$pandoc$args) | ||||||||
| perf_timer_start("pandoc") | ||||||||
| convert <- function(output, citeproc = FALSE) { | ||||||||
| # temporarily move figures and bib files to the intermediate dir if | ||||||||
| # specified: https://github.com/rstudio/rmarkdown/issues/500 | ||||||||
| if (!is.null(intermediates_dir)) { | ||||||||
| figures_dir <- gsub('/$', '', knitr::opts_chunk$get("fig.path")) | ||||||||
| files <- list.files(figures_dir, full.names = TRUE, recursive = TRUE) | ||||||||
| # https://github.com/rstudio/rmarkdown/issues/1358 | ||||||||
| if (citeproc) files <- c(files, front_matter[['bibliography']]) | ||||||||
| for (f in files) { | ||||||||
| intermediates <<- c(intermediates, copy_file_with_dir(f, intermediates_dir)) | ||||||||
| } | ||||||||
| } | ||||||||
| # ensure we expand paths (for Windows where leading `~/` does | ||||||||
| # not get expanded by pandoc) | ||||||||
| utf8_input <- path.expand(utf8_input) | ||||||||
| output <- path.expand(output) | ||||||||
| pandoc_args <- output_format$pandoc$args | ||||||||
| # if Lua filters are provided, add the command line switch | ||||||||
| if (!is.null(lua_filters <- output_format$pandoc$lua_filters)) { | ||||||||
| lua_filters <- pandoc_lua_filter_args(lua_filters) | ||||||||
| } | ||||||||
| pandoc_args <- c(lua_filters, pandoc_args) | ||||||||
| # in case the output format turns on the --file-scope flag, run its | ||||||||
| # file_scope function to split the input into multiple files | ||||||||
| input_files <- utf8_input | ||||||||
| if (!is.null(output_format$file_scope) && | ||||||||
| length(inputs <- output_format$file_scope(utf8_input)) > 1) { | ||||||||
| # add the --file-scope option | ||||||||
| pandoc_args <- c(pandoc_args, "--file-scope") | ||||||||
| # write the split content into *.split.md files | ||||||||
| input_files <- unlist(lapply(inputs, function(input) { | ||||||||
| file <- file_with_meta_ext(input$name, "split", "md") | ||||||||
| file <- file.path(dirname(utf8_input), file) | ||||||||
| write_utf8(input$content, file) | ||||||||
| file | ||||||||
| })) | ||||||||
| # cleanup the split files after render | ||||||||
| on.exit(unlink(input_files), add = TRUE) | ||||||||
| } | ||||||||
| # if we don't detect any invalid shell characters in the | ||||||||
| # target path, then just call pandoc directly | ||||||||
| if (!grepl(.shell_chars_regex, output) && !grepl(.shell_chars_regex, utf8_input)) { | ||||||||
| return(pandoc_convert( | ||||||||
| input_files, pandoc_to, output_format$pandoc$from, output, | ||||||||
| citeproc, pandoc_args, !quiet | ||||||||
| )) | ||||||||
| } | ||||||||
| # render to temporary file (preserve extension) | ||||||||
| # this also ensures we don't pass a file path with invalid | ||||||||
| # characters to our pandoc invocation | ||||||||
| ext <- xfun::file_ext(output) | ||||||||
| if (ext != '') ext <- paste0('.', ext) | ||||||||
| # render to a path in the current working directory | ||||||||
| # (avoid passing invalid characters to shell) | ||||||||
| pandoc_output_tmp <- basename(tempfile("pandoc", getwd(), ext)) | ||||||||
| # clean up temporary file on exit | ||||||||
| on.exit(unlink(pandoc_output_tmp), add = TRUE) | ||||||||
| # call pandoc to render file | ||||||||
| status <- pandoc_convert( | ||||||||
| input_files, pandoc_to, output_format$pandoc$from, pandoc_output_tmp, | ||||||||
| citeproc, pandoc_args, !quiet | ||||||||
| ) | ||||||||
| # construct output path (when passed only a file name to '--output', | ||||||||
| # pandoc seems to render in the same directory as the input file) | ||||||||
| pandoc_output_tmp_path <- file.path(dirname(utf8_input), pandoc_output_tmp) | ||||||||
| # rename output file to desired location | ||||||||
| renamed <- suppressWarnings(file.rename(pandoc_output_tmp_path, output)) | ||||||||
| # rename can fail if the temporary directory and output path | ||||||||
| # lie on different volumes; in such a case attempt a file copy | ||||||||
| # see: https://github.com/rstudio/rmarkdown/issues/705 | ||||||||
| if (!renamed) { | ||||||||
| copied <- file.copy(pandoc_output_tmp_path, output, overwrite = TRUE) | ||||||||
| if (!copied) { | ||||||||
| stop("failed to copy rendered pandoc artefact to '", output, "'") | ||||||||
| } | ||||||||
| } | ||||||||
| # return status | ||||||||
| status | ||||||||
| } | ||||||||
| texfile <- file_with_ext(output_file, "tex") | ||||||||
| # determine whether we need to run citeproc (based on whether we have | ||||||||
| # references in the input) | ||||||||
| run_citeproc <- citeproc_required(front_matter, input_lines) | ||||||||
| # if the output format is LaTeX, first convert .md to .tex, and then convert | ||||||||
| # .tex to .pdf via latexmk() if PDF output is requested (in rmarkdown <= | ||||||||
| # v1.8, we used to call Pandoc to convert .md to .tex and .pdf separately) | ||||||||
| if (output_format$pandoc$keep_tex || knitr::is_latex_output()) { | ||||||||
| # do not use pandoc-citeproc if needs to build bibliography | ||||||||
| convert(texfile, run_citeproc && !need_bibtex) | ||||||||
| # patch the .tex output generated from the default Pandoc LaTeX template | ||||||||
| if (!("--template" %in% output_format$pandoc$args)) patch_tex_output(texfile) | ||||||||
| fix_horiz_rule(texfile) | ||||||||
| # unless the output file has the extension .tex, we assume it is PDF | ||||||||
| if (!grepl('[.]tex$', output_file)) { | ||||||||
| latexmk(texfile, output_format$pandoc$latex_engine, '--biblatex' %in% output_format$pandoc$args) | ||||||||
| file.rename(file_with_ext(texfile, "pdf"), output_file) | ||||||||
| # clean up the tex file if necessary | ||||||||
| if (!output_format$pandoc$keep_tex) { | ||||||||
| texfile <- normalize_path(texfile) | ||||||||
| on.exit(unlink(texfile), add = TRUE) | ||||||||
| } | ||||||||
| } | ||||||||
| } else { | ||||||||
| convert(output_file, run_citeproc) | ||||||||
| } | ||||||||
| # pandoc writes the output alongside the input, so if we rendered from an | ||||||||
| # intermediate directory, move the output file | ||||||||
| if (!is.null(intermediates_dir)) { | ||||||||
| intermediate_output <- file.path(intermediates_dir, basename(output_file)) | ||||||||
| if (file.exists(intermediate_output)) { | ||||||||
| file.rename(intermediate_output, output_file) | ||||||||
| } | ||||||||
| } | ||||||||
| perf_timer_stop("pandoc") | ||||||||
| perf_timer_start("post-processor") | ||||||||
| # if there is a post-processor then call it | ||||||||
| if (!is.null(output_format$post_processor)) | ||||||||
| output_file <- output_format$post_processor(front_matter, | ||||||||
| utf8_input, | ||||||||
| output_file, | ||||||||
| clean, | ||||||||
| !quiet) | ||||||||
| if (!quiet) { | ||||||||
| message("\nOutput created: ", relative_to(oldwd, output_file)) | ||||||||
| } | ||||||||
| perf_timer_stop("post-processor") | ||||||||
| } | ||||||||
| perf_timer_stop("render") | ||||||||
| # write markdown output if requested | ||||||||
| if (output_format$keep_md && !md_input) { | ||||||||
| file.copy(input, file_with_ext(output_file, "md"), overwrite = TRUE) | ||||||||
| } | ||||||||
| if (run_pandoc) { | ||||||||
| # return the full path to the output file | ||||||||
| output_file <- abs_path(output_file) | ||||||||
| # attach the metadata specified as rmd_output_metadata in YAML | ||||||||
| if (length(output_meta <- output_metadata$get())) | ||||||||
| attr(output_file, 'rmd_output_metadata') <- output_meta | ||||||||
| invisible(output_file) | ||||||||
| } else { | ||||||||
| # make sure the markdown output and fig dir are not cleaned up | ||||||||
| intermediates <- setdiff(intermediates, c(input, intermediates_fig)) | ||||||||
| # did not run pandoc; returns the markdown output with attributes of the | ||||||||
| # knitr meta data and intermediate files | ||||||||
| structure(input, | ||||||||
| knit_meta = knit_meta, | ||||||||
| files_dir = files_dir, | ||||||||
| intermediates_dir = intermediates_fig, | ||||||||
| intermediates = intermediates) | ||||||||
| } | ||||||||
| } | ||||||||
| #' Render supporting files for an input document | ||||||||
| #' | ||||||||
| #' Render (copy) required supporting files for an input document to the | ||||||||
| #' \code{_files} directory that is associated with the document. | ||||||||
| #' | ||||||||
| #' @param from The directory from which the files should be copied. | ||||||||
| #' @param files_dir The directory that will receive the copied files. | ||||||||
| #' @param rename_to An option to rename the source directory after the copy | ||||||||
| #' operation is complete. | ||||||||
| #' @return The relative path to the supporting files. This path is suitable | ||||||||
| #' for inclusion in HTML\code{href} and \code{src} attributes. | ||||||||
| #' @export | ||||||||
| render_supporting_files <- function(from, files_dir, rename_to = NULL) { | ||||||||
| # auto-create directory for supporting files | ||||||||
| if (!dir_exists(files_dir)) | ||||||||
| dir.create(files_dir) | ||||||||
| # target directory is based on the dirname of the path or the rename_to | ||||||||
| # value if it was provided | ||||||||
| target_stage_dir <- file.path(files_dir, basename(from)) | ||||||||
| target_dir <- file.path(files_dir, ifelse(is.null(rename_to), | ||||||||
| basename(from), | ||||||||
| rename_to)) | ||||||||
| # copy the directory if it hasn't already been copied | ||||||||
| if (!dir_exists(target_dir) && !dir_exists(target_stage_dir)) { | ||||||||
| file.copy(from = from, | ||||||||
| to = files_dir, | ||||||||
| recursive = TRUE, | ||||||||
| copy.mode = FALSE) | ||||||||
| if (!is.null(rename_to)) { | ||||||||
| file.rename(from = target_stage_dir, | ||||||||
| to = target_dir) | ||||||||
| } | ||||||||
| } | ||||||||
| # return the target dir (used to form links in the HTML) | ||||||||
| target_dir | ||||||||
| } | ||||||||
| # reset knitr meta output (returns any meta output generated since the last | ||||||||
| # call to knit_meta_reset), optionally scoped to a specific output class | ||||||||
| knit_meta_reset <- function(class = NULL) { | ||||||||
| knitr::knit_meta(class, clean = TRUE) | ||||||||
| } | ||||||||
| # render context (render-related state can be stuffed here) | ||||||||
| .render_context <- NULL # initialized in .onLoad | ||||||||
| render_context <- function() { | ||||||||
| .render_context$peek() | ||||||||
| } | ||||||||
| init_render_context <- function() { | ||||||||
| .render_context$push(new_render_context()) | ||||||||
| } | ||||||||
| clear_render_context <- function() { | ||||||||
| .render_context$pop() | ||||||||
| } | ||||||||
| new_render_context <- function() { | ||||||||
| env <- new.env(parent = emptyenv()) | ||||||||
| env$chunk.index <- 1 | ||||||||
| env | ||||||||
| } | ||||||||
| merge_render_context <- function(context) { | ||||||||
| elements <- ls(envir = render_context(), all.names = TRUE) | ||||||||
| for (el in elements) | ||||||||
| context[[el]] <- get(el, envir = render_context()) | ||||||||
| context | ||||||||
| } | ||||||||
| id_prefix_from_args <- function(args) { | ||||||||
| # scan for id-prefix argument | ||||||||
| for (i in 1:length(args)) { | ||||||||
| arg <- args[[i]] | ||||||||
| if (identical(arg, "--id-prefix") && (i < length(args))) | ||||||||
| return(args[[i + 1]]) | ||||||||
| } | ||||||||
| # default to empty string | ||||||||
| "" | ||||||||
| } | ||||||||
| resolve_df_print <- function(df_print) { | ||||||||
| # available methods | ||||||||
| valid_methods <- c("default", "kable", "tibble", "paged") | ||||||||
| # if we are passed NULL then select the first method | ||||||||
| if (is.null(df_print)) | ||||||||
| df_print <- valid_methods[[1]] | ||||||||
| # if we are passed all of valid_methods then select the first one | ||||||||
| if (identical(valid_methods, df_print)) | ||||||||
| df_print <- valid_methods[[1]] | ||||||||
| if (!is.function(df_print)) { | ||||||||
| if (df_print == "kable") | ||||||||
| df_print <- knitr::kable | ||||||||
| else if (df_print == "tibble") { | ||||||||
| if (!requireNamespace("tibble", quietly = TRUE)) | ||||||||
| stop("Printing 'tibble' without 'tibble' package available") | ||||||||
| df_print <- function(x) print(tibble::as_tibble(x)) | ||||||||
| } | ||||||||
| else if (df_print == "paged") | ||||||||
| df_print <- function(x) { | ||||||||
| if (!identical(knitr::opts_current$get("paged.print"), FALSE)) { | ||||||||
| knitr::asis_output(paged_table_html(x)) | ||||||||
| } | ||||||||
| else { | ||||||||
| print(x) | ||||||||
| } | ||||||||
| } | ||||||||
| else if (df_print == "default") | ||||||||
| df_print <- print | ||||||||
| else | ||||||||
| stop('Invalid value for df_print (valid values are ', | ||||||||
| paste(valid_methods, collapse = ", "), call. = FALSE) | ||||||||
| } | ||||||||
| df_print | ||||||||
| } | ||||||||
| # package level globals | ||||||||
| .globals <- new.env(parent = emptyenv()) | ||||||||
| .globals$evaluated_global_chunks <- character() | ||||||||
| .globals$level <- 0L | ||||||||
| #' The output metadata object | ||||||||
| #' | ||||||||
| #' This object provides a mechanism for users to attach metadata as an attribute | ||||||||
| #' (named \code{rmd_output_metadata}) of the returned value of | ||||||||
| #' \code{\link{render}()}. The initial value of the metadata comes from in the | ||||||||
| #' \code{rmd_output_metadata} field of the YAML frontmatter of an R Markdown | ||||||||
| #' document. The metadata can be queried via the | ||||||||
| #' \code{output_metadata$get()} method, and modified via the | ||||||||
| #' \code{output_metadata$set()} method. | ||||||||
| #' @format NULL | ||||||||
| #' @usage NULL | ||||||||
| #' @keywords NULL | ||||||||
| #' @export | ||||||||
| output_metadata = knitr:::new_defaults() | ||||||||
| 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) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| map_data = function(data, layout, params) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) { | ||||||||
| scales <- list() | ||||||||
| if (!is.null(x_scale)) { | ||||||||
| scales$x <- lapply(seq_len(max(layout$SCALE_X)), function(i) x_scale$clone()) | ||||||||
| } | ||||||||
| if (!is.null(y_scale)) { | ||||||||
| scales$y <- lapply(seq_len(max(layout$SCALE_Y)), function(i) 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) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| 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$.possible_columns <- unique(unlist(lapply(data, names))) | ||||||||
| 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(...) { | ||||||||
| 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 <- lapply(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)) | ||||||||
| ) | ||||||||
| 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, "uneval")) { | ||||||||
| abort("Please use `vars()` to supply facet variables") | ||||||||
| } | ||||||||
| if (is_quosures(x)) { | ||||||||
| x <- 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 (is_string(x)) { | ||||||||
| x <- 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 (is_formula(x)) { | ||||||||
| return(f_as_facets_list(x)) | ||||||||
| } | ||||||||
| # For backward-compatibility with facet_wrap() | ||||||||
| if (!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) | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| # Flatten a list of quosures objects to a quosures object, and compact it | ||||||||
| compact_facets <- function(x) { | ||||||||
| x <- flatten_if(x, is_list) | ||||||||
| null <- vapply(x, quo_is_null, logical(1)) | ||||||||
| new_quosures(x[!null]) | ||||||||
| } | ||||||||
| # Compatibility with plyr::as.quoted() | ||||||||
| as_quoted <- function(x) { | ||||||||
| if (is.character(x)) { | ||||||||
| if (length(x) > 1) { | ||||||||
| x <- paste(x, collapse = "; ") | ||||||||
| } | ||||||||
| return(parse_exprs(x)) | ||||||||
| } | ||||||||
| if (is.null(x)) { | ||||||||
| return(list()) | ||||||||
| } | ||||||||
| if (is_formula(x)) { | ||||||||
| return(simplify(x)) | ||||||||
| } | ||||||||
| list(x) | ||||||||
| } | ||||||||
| # From plyr:::as.quoted.formula | ||||||||
| simplify <- function(x) { | ||||||||
| if (length(x) == 2 && 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 (is_symbol(op, c("+", "*", "~"))) { | ||||||||
| c(simplify(a), simplify(b)) | ||||||||
| } else if (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)) | ||||||||
| list(rows, cols) | ||||||||
| } | ||||||||
| as_facets <- function(x) { | ||||||||
| if (is_facets(x)) { | ||||||||
| return(x) | ||||||||
| } | ||||||||
| if (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 <- f_env(f) %||% globalenv() | ||||||||
| # as.quoted() handles `+` specifications | ||||||||
| vars <- 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, 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, possible_columns = NULL) { | ||||||||
| vars <- compact(lapply(facets, eval_facet, data, possible_columns = possible_columns)) | ||||||||
| new_data_frame(tibble::as_tibble(vars)) | ||||||||
| } | ||||||||
| eval_facet <- function(facet, data, possible_columns = NULL) { | ||||||||
| # Treat the case when `facet` is a quosure of a symbol specifically | ||||||||
| # to issue a friendlier warning | ||||||||
| if (quo_is_symbol(facet)) { | ||||||||
| facet <- as.character(quo_get_expr(facet)) | ||||||||
| if (facet %in% names(data)) { | ||||||||
| out <- data[[facet]] | ||||||||
| } else { | ||||||||
| out <- NULL | ||||||||
| } | ||||||||
| return(out) | ||||||||
| } | ||||||||
| # Key idea: use active bindings so that column names missing in this layer | ||||||||
| # but present in others raise a custom error | ||||||||
| env <- new_environment(data) | ||||||||
| missing_columns <- setdiff(possible_columns, names(data)) | ||||||||
| undefined_error <- function(e) abort("", class = "ggplot2_missing_facet_var") | ||||||||
| bindings <- rep_named(missing_columns, list(undefined_error)) | ||||||||
| env_bind_active(env, !!!bindings) | ||||||||
| # Create a data mask and install a data pronoun manually (see ?new_data_mask) | ||||||||
| mask <- new_data_mask(env) | ||||||||
| mask$.data <- as_data_pronoun(mask) | ||||||||
| tryCatch( | ||||||||
| eval_tidy(facet, mask), | ||||||||
| ggplot2_missing_facet_var = function(e) NULL | ||||||||
| ) | ||||||||
| } | ||||||||
| layout_null <- function() { | ||||||||
| # PANEL needs to be a factor to be consistent with other facet types | ||||||||
| new_data_frame(list(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() | ||||||||
| } | ||||||||
| abort("Facet layout has bad format. It must contain columns 'PANEL', 'SCALE_X', and 'SCALE_Y'") | ||||||||
| } | ||||||||
| #' Get the maximal width/length of a list of grobs | ||||||||
| #' | ||||||||
| #' @param grobs A list of grobs | ||||||||
| #' @param value_only Should the return value be a simple numeric vector giving | ||||||||
| #' the maximum in cm | ||||||||
| #' | ||||||||
| #' @return The largest value. measured in cm as a unit object or a numeric | ||||||||
| #' vector depending on `value_only` | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| max_height <- function(grobs, value_only = FALSE) { | ||||||||
| height <- max(unlist(lapply(grobs, height_cm))) | ||||||||
| if (!value_only) height <- unit(height, "cm") | ||||||||
| height | ||||||||
| } | ||||||||
| #' @rdname max_height | ||||||||
| #' @export | ||||||||
| max_width <- function(grobs, value_only = FALSE) { | ||||||||
| width <- max(unlist(lapply(grobs, width_cm))) | ||||||||
| if (!value_only) width <- unit(width, "cm") | ||||||||
| width | ||||||||
| } | ||||||||
| #' 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(list( | ||||||||
| t = min(.subset2(panels, "t")), | ||||||||
| r = max(.subset2(panels, "r")), | ||||||||
| b = max(.subset2(panels, "b")), | ||||||||
| l = min(.subset2(panels, "l")) | ||||||||
| ), n = 1) | ||||||||
| } | ||||||||
| #' @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) { | ||||||||
| possible_columns <- unique(unlist(lapply(data, names))) | ||||||||
| if (length(vars) == 0) return(new_data_frame()) | ||||||||
| # For each layer, compute the facet values | ||||||||
| values <- compact(lapply(data, eval_facets, facets = vars, possible_columns = possible_columns)) | ||||||||
| # 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))) | ||||||||
| abort(glue( | ||||||||
| "At least one layer must contain all faceting variables: {var_list(names(vars))}.\n", | ||||||||
| glue_collapse(glue("* {name} is missing {missing_txt}"), "\n", last = "\n") | ||||||||
| )) | ||||||||
| } | ||||||||
| base <- unique(rbind_dfs(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 <- unique(rbind(base, df.grid(old, new))) | ||||||||
| } | ||||||||
| if (empty(base)) { | ||||||||
| abort("Faceting variables must have at least one value") | ||||||||
| } | ||||||||
| 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. | ||||||||
| #' If you have only one variable with many levels, try [facet_wrap()]. | ||||||||
| #' | ||||||||
| #' @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 `vars(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()]. You can use different labeling | ||||||||
| #' functions for different kind of labels, for example use [label_parsed()] for | ||||||||
| #' formatting facet labels. [label_value()] is used by default, | ||||||||
| #' check it 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 use `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)) | ||||||||
| #' | ||||||||
| #' # 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(vars(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")) { | ||||||||
| abort("switch must be either 'both', 'x', or 'y'") | ||||||||
| } | ||||||||
| facets_list <- grid_as_facets_list(rows, cols) | ||||||||
| # Check for deprecated labellers | ||||||||
| labeller <- check_labeller(labeller) | ||||||||
| ggproto(NULL, FacetGrid, | ||||||||
| shrink = shrink, | ||||||||
| params = list(rows = facets_list$rows, cols = facets_list$cols, margins = margins, | ||||||||
| free = free, space_free = space_free, labeller = labeller, | ||||||||
| as.table = as.table, switch = switch, drop = drop) | ||||||||
| ) | ||||||||
| } | ||||||||
| # Returns a list of quosures objects. The list has exactly two elements, `rows` and `cols`. | ||||||||
| grid_as_facets_list <- function(rows, cols) { | ||||||||
| is_rows_vars <- is.null(rows) || is_quosures(rows) | ||||||||
| if (!is_rows_vars) { | ||||||||
| if (!is.null(cols)) { | ||||||||
| abort("`rows` must be `NULL` or a `vars()` list if `cols` is a `vars()` list") | ||||||||
| } | ||||||||
| # For backward-compatibility | ||||||||
| facets_list <- as_facets_list(rows) | ||||||||
| if (length(facets_list) > 2L) { | ||||||||
| abort("A grid facet specification can't have more than two dimensions") | ||||||||
| } | ||||||||
| # Fill with empty quosures | ||||||||
| facets <- list(rows = quos(), cols = quos()) | ||||||||
| facets[seq_along(facets_list)] <- facets_list | ||||||||
| # Do not compact the legacy specs | ||||||||
| return(facets) | ||||||||
| } | ||||||||
| is_cols_vars <- is.null(cols) || is_quosures(cols) | ||||||||
| if (!is_cols_vars) { | ||||||||
| abort("`cols` must be `NULL` or a `vars()` specification") | ||||||||
| } | ||||||||
| list( | ||||||||
| rows = compact_facets(as_facets_list(rows)), | ||||||||
| cols = compact_facets(as_facets_list(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) { | ||||||||
| abort(glue( | ||||||||
| "Faceting variables can only appear in row or cols, not both.\n", | ||||||||
| "Problems: ", paste0(dups, collapse = "'") | ||||||||
| )) | ||||||||
| } | ||||||||
| 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) | ||||||||
| if (nrow(base) == 0) { | ||||||||
| return(new_data_frame(list(PANEL = factor(1L), ROW = 1L, COL = 1L, SCALE_X = 1L, SCALE_Y = 1L))) | ||||||||
| } | ||||||||
| # Add margins | ||||||||
| base <- reshape_add_margins(base, list(names(rows), names(cols)), params$margins) | ||||||||
| base <- unique(base) | ||||||||
| # Create panel info dataset | ||||||||
| panel <- id(base, drop = TRUE) | ||||||||
| panel <- factor(panel, levels = seq_len(attr(panel, "n"))) | ||||||||
| rows <- if (!length(names(rows))) rep(1L, length(panel)) else id(base[names(rows)], drop = TRUE) | ||||||||
| cols <- if (!length(names(cols))) rep(1L, length(panel)) else id(base[names(cols)], drop = TRUE) | ||||||||
| panels <- new_data_frame(c(list(PANEL = panel, ROW = rows, COL = cols), base)) | ||||||||
| 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)) | ||||||||
| if (length(vars) == 0) { | ||||||||
| data$PANEL <- layout$PANEL | ||||||||
| return(data) | ||||||||
| } | ||||||||
| # Compute faceting values and add margins | ||||||||
| margin_vars <- list(intersect(names(rows), names(data)), | ||||||||
| intersect(names(cols), names(data))) | ||||||||
| data <- reshape_add_margins(data, margin_vars, params$margins) | ||||||||
| facet_vals <- eval_facets(c(rows, cols), data, params$.possible_columns) | ||||||||
| # 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 <- unrowname(data[data_rep, , drop = FALSE]) | ||||||||
| facet_vals <- 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 <- 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()) { | ||||||||
| abort(glue("{snake_class(coord)} doesn't support free scales")) | ||||||||
| } | ||||||||
| 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(nrow), ncol), '-', rep(seq_len(ncol), each = nrow)) | ||||||||
| 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/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)))) { | ||||||||
| abort("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)) { | ||||||||
| abort("`_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 { | ||||||||
| abort(glue(" | ||||||||
| {class(x)[[1]]} was built with an incompatible version of ggproto. | ||||||||
| Please reinstall the package that provides this extension. | ||||||||
| ")) | ||||||||
| } | ||||||||
| } | ||||||||
| 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/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) | ||||||||
| ), | ||||||||
| self$panel_params[[1]] | ||||||||
| ) | ||||||||
| 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() | ||||||||
| }, | ||||||||
| setup_panel_guides = function(self, guides, layers, default_mapping) { | ||||||||
| self$panel_params <- lapply( | ||||||||
| self$panel_params, | ||||||||
| self$coord$setup_panel_guides, | ||||||||
| guides, | ||||||||
| self$coord_params | ||||||||
| ) | ||||||||
| self$panel_params <- lapply( | ||||||||
| self$panel_params, | ||||||||
| self$coord$train_panel_guides, | ||||||||
| layers, | ||||||||
| default_mapping, | ||||||||
| self$coord_params | ||||||||
| ) | ||||||||
| 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() | ||||||||
| if (any(is.na(scale_id))) { | ||||||||
| abort("`scale_id` must not be `NA`") | ||||||||
| } | ||||||||
| scale_index <- split_with_index(seq_along(scale_id), scale_id, length(scales)) | ||||||||
| lapply(vars, function(var) { | ||||||||
| pieces <- lapply(seq_along(scales), function(i) { | ||||||||
| scales[[i]][[method]](data[[var]][scale_index[[i]]]) | ||||||||
| }) | ||||||||
| o <- order(unlist(scale_index))[seq_len(sum(lengths(pieces)))] | ||||||||
| do.call("c", pieces)[o] | ||||||||
| }) | ||||||||
| } | ||||||||
| 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 return the data, grob, or scales associated with a given | ||||||||
| #' layer. These are useful for tests. | ||||||||
| #' | ||||||||
| #' @param plot ggplot object | ||||||||
| #' @param i An integer. In `layer_data()`, the data to return (in the order added to the | ||||||||
| #' plot). In `layer_grob()`, the grob to return (in the order added to the | ||||||||
| #' plot). In `layer_scales()`, the row of a facet to return scales for. | ||||||||
| #' @param j An integer. In `layer_scales()`, the column of a facet to return | ||||||||
| #' scales for. | ||||||||
| #' @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 | ||||||||
| } | ||||||||
| # Allow all layers to make any final adjustments based | ||||||||
| # on raw input data and plot info | ||||||||
| data <- layer_data | ||||||||
| data <- by_layer(function(l, d) l$setup_layer(d, plot)) | ||||||||
| # 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(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) | ||||||||
| layout$setup_panel_guides(plot$guides, plot$layers, plot$mapping) | ||||||||
| 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) | ||||||||
| # positioning of title and subtitle is governed by plot.title.position | ||||||||
| # positioning of caption is governed by plot.caption.position | ||||||||
| # "panel" means align to the panel(s) | ||||||||
| # "plot" means align to the entire plot (except margins and tag) | ||||||||
| title_pos <- theme$plot.title.position %||% "panel" | ||||||||
| if (!(title_pos %in% c("panel", "plot"))) { | ||||||||
| abort('plot.title.position should be either "panel" or "plot".') | ||||||||
| } | ||||||||
| caption_pos <- theme$plot.caption.position %||% "panel" | ||||||||
| if (!(caption_pos %in% c("panel", "plot"))) { | ||||||||
| abort('plot.caption.position should be either "panel" or "plot".') | ||||||||
| } | ||||||||
| pans <- plot_table$layout[grepl("^panel", plot_table$layout$name), , drop = FALSE] | ||||||||
| if (title_pos == "panel") { | ||||||||
| title_l = min(pans$l) | ||||||||
| title_r = max(pans$r) | ||||||||
| } else { | ||||||||
| title_l = 1 | ||||||||
| title_r = ncol(plot_table) | ||||||||
| } | ||||||||
| if (caption_pos == "panel") { | ||||||||
| caption_l = min(pans$l) | ||||||||
| caption_r = max(pans$r) | ||||||||
| } else { | ||||||||
| caption_l = 1 | ||||||||
| caption_r = ncol(plot_table) | ||||||||
| } | ||||||||
| 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 = title_l, r = title_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 = title_l, r = title_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 = caption_l, r = caption_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)) { | ||||||||
| abort(glue("plot.tag.position should be a coordinate or one of ", | ||||||||
| glue_collapse(valid_pos, ', ', last = " or "))) | ||||||||
| } | ||||||||
| 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)) | ||||||||
| } | ||||||||
| scales/R/trans.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Create a new transformation object | ||||||||
| #' | ||||||||
| #' A transformation encapsulates a transformation and its inverse, as well | ||||||||
| #' as the information needed to create pleasing breaks and labels. The breaks | ||||||||
| #' function is applied on the transformed range of the range, and it's | ||||||||
| #' expected that the labels function will perform some kind of inverse | ||||||||
| #' transformation on these breaks to give them labels that are meaningful on | ||||||||
| #' the original scale. | ||||||||
| #' | ||||||||
| #' @param name transformation name | ||||||||
| #' @param transform function, or name of function, that performs the | ||||||||
| #' transformation | ||||||||
| #' @param inverse function, or name of function, that performs the | ||||||||
| #' inverse of the transformation | ||||||||
| #' @param breaks default breaks function for this transformation. The breaks | ||||||||
| #' function is applied to the raw data. | ||||||||
| #' @param minor_breaks default minor breaks function for this transformation. | ||||||||
| #' @param format default format for this transformation. The format is applied | ||||||||
| #' to breaks generated to the raw data. | ||||||||
| #' @param domain domain, as numeric vector of length 2, over which | ||||||||
| #' transformation is valued | ||||||||
| #' @seealso \Sexpr[results=rd,stage=build]{scales:::seealso_trans()} | ||||||||
| #' @export | ||||||||
| #' @keywords internal | ||||||||
| #' @aliases trans | ||||||||
| trans_new <- function(name, transform, inverse, breaks = extended_breaks(), | ||||||||
| minor_breaks = regular_minor_breaks(), | ||||||||
| format = format_format(), domain = c(-Inf, Inf)) { | ||||||||
| if (is.character(transform)) transform <- match.fun(transform) | ||||||||
| if (is.character(inverse)) inverse <- match.fun(inverse) | ||||||||
| structure( | ||||||||
| list( | ||||||||
| name = name, | ||||||||
| transform = transform, | ||||||||
| inverse = inverse, | ||||||||
| breaks = breaks, | ||||||||
| minor_breaks = minor_breaks, | ||||||||
| format = format, | ||||||||
| domain = domain | ||||||||
| ), | ||||||||
| class = "trans" | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @rdname trans_new | ||||||||
| #' @export | ||||||||
| is.trans <- function(x) inherits(x, "trans") | ||||||||
| #' @export | ||||||||
| print.trans <- function(x, ...) cat("Transformer: ", x$name, "\n") | ||||||||
| #' @export | ||||||||
| plot.trans <- function(x, y, ..., xlim, ylim = NULL) { | ||||||||
| if (is.null(ylim)) { | ||||||||
| ylim <- range(x$transform(seq(xlim[1], xlim[2], length = 100)), finite = TRUE) | ||||||||
| } | ||||||||
| plot( | ||||||||
| xlim, ylim, | ||||||||
| xlab = "", | ||||||||
| ylab = "", | ||||||||
| type = "n", | ||||||||
| main = paste0("Transformer: ", x$name), | ||||||||
| ) | ||||||||
| graphics::grid(lty = "solid") | ||||||||
| graphics::abline(h = 0, v = 0, col = "grey90", lwd = 5) | ||||||||
| graphics::lines(x, xlim = xlim) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| lines.trans <- function(x, ..., xlim) { | ||||||||
| xgrid <- seq(xlim[1], xlim[2], length = 100) | ||||||||
| y <- suppressWarnings(x$transform(xgrid)) | ||||||||
| graphics::lines(xgrid, y, ...) | ||||||||
| } | ||||||||
| #' @rdname trans_new | ||||||||
| #' @export | ||||||||
| as.trans <- function(x) { | ||||||||
| if (is.trans(x)) return(x) | ||||||||
| f <- paste0(x, "_trans") | ||||||||
| match.fun(f)() | ||||||||
| } | ||||||||
| #' Compute range of transformed values | ||||||||
| #' | ||||||||
| #' Silently drops any ranges outside of the domain of `trans`. | ||||||||
| #' | ||||||||
| #' @param trans a transformation object, or the name of a transformation object | ||||||||
| #' given as a string. | ||||||||
| #' @param x a numeric vector to compute the range of | ||||||||
| #' @export | ||||||||
| #' @keywords internal | ||||||||
| trans_range <- function(trans, x) { | ||||||||
| trans <- as.trans(trans) | ||||||||
| range(trans$transform(range(squish(x, trans$domain), na.rm = TRUE))) | ||||||||
| } | ||||||||
| scales/R/trans-numeric.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Arc-sin square root transformation | ||||||||
| #' | ||||||||
| #' This is the variance stabilising transformation for the binomial | ||||||||
| #' distribution. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' plot(asn_trans(), xlim = c(0, 1)) | ||||||||
| asn_trans <- function() { | ||||||||
| trans_new( | ||||||||
| "asn", | ||||||||
| function(x) 2 * asin(sqrt(x)), | ||||||||
| function(x) sin(x / 2)^2 | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Arc-tangent transformation | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' plot(atanh_trans(), xlim = c(-1, 1)) | ||||||||
| atanh_trans <- function() { | ||||||||
| trans_new("atanh", "atanh", "tanh") | ||||||||
| } | ||||||||
| #' Box-Cox & modulus transformations | ||||||||
| #' | ||||||||
| #' The Box-Cox transformation is a flexible transformation, often used to | ||||||||
| #' transform data towards normality. The modulus transformation generalises | ||||||||
| #' Box-Cox to also work with negative values. | ||||||||
| #' | ||||||||
| #' The Box-Cox power transformation (type 1) requires strictly positive values and | ||||||||
| #' takes the following form for `y > 0`: | ||||||||
| #' \deqn{y^{(\lambda)} = \frac{y^\lambda - 1}{\lambda}}{y^(\lambda) = (y^\lambda - 1)/\lambda} | ||||||||
| #' When `y = 0`, the natural log transform is used. | ||||||||
| #' | ||||||||
| #' The modulus transformation implements a generalisation of the Box-Cox | ||||||||
| #' transformation that works for data with both positive and negative values. | ||||||||
| #' The equation takes the following forms, when `y != 0` : | ||||||||
| #' \deqn{y^{(\lambda)} = sign(y) * \frac{(|y| + 1)^\lambda - 1}{\lambda}}{ | ||||||||
| #' y^(\lambda) = sign(y)*((|y|+1)^\lambda - 1)/\lambda} | ||||||||
| #' and when `y = 0`: \deqn{y^{(\lambda)} = sign(y) * \ln(|y| + 1)}{ | ||||||||
| #' y^(\lambda) = sign(y) * ln(|y| + 1)} | ||||||||
| #' | ||||||||
| #' @param p Transformation exponent, \eqn{\lambda}. | ||||||||
| #' @param offset Constant offset. 0 for Box-Cox type 1, | ||||||||
| #' otherwise any non-negative constant (Box-Cox type 2). `modulus_trans()` | ||||||||
| #' sets the default to 1. | ||||||||
| #' @seealso [yj_trans()] | ||||||||
| #' @references Box, G. E., & Cox, D. R. (1964). An analysis of transformations. | ||||||||
| #' Journal of the Royal Statistical Society. Series B (Methodological), 211-252. | ||||||||
| #' \url{https://www.jstor.org/stable/2984418} | ||||||||
| #' | ||||||||
| #' John, J. A., & Draper, N. R. (1980). | ||||||||
| #' An alternative family of transformations. Applied Statistics, 190-197. | ||||||||
| #' \url{http://www.jstor.org/stable/2986305} | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' plot(boxcox_trans(-1), xlim = c(0, 10)) | ||||||||
| #' plot(boxcox_trans(0), xlim = c(0, 10)) | ||||||||
| #' plot(boxcox_trans(1), xlim = c(0, 10)) | ||||||||
| #' plot(boxcox_trans(2), xlim = c(0, 10)) | ||||||||
| #' | ||||||||
| #' plot(modulus_trans(-1), xlim = c(-10, 10)) | ||||||||
| #' plot(modulus_trans(0), xlim = c(-10, 10)) | ||||||||
| #' plot(modulus_trans(1), xlim = c(-10, 10)) | ||||||||
| #' plot(modulus_trans(2), xlim = c(-10, 10)) | ||||||||
| boxcox_trans <- function(p, offset = 0) { | ||||||||
| trans <- function(x) { | ||||||||
| if (any((x + offset) < 0, na.rm = TRUE)) { | ||||||||
| stop("boxcox_trans must be given only positive values. Consider using modulus_trans instead?", | ||||||||
| call. = F | ||||||||
| ) | ||||||||
| } | ||||||||
| if (abs(p) < 1e-07) { | ||||||||
| log(x + offset) | ||||||||
| } else { | ||||||||
| ((x + offset)^p - 1) / p | ||||||||
| } | ||||||||
| } | ||||||||
| inv <- function(x) { | ||||||||
| if (abs(p) < 1e-07) { | ||||||||
| exp(x) - offset | ||||||||
| } else { | ||||||||
| (x * p + 1)^(1 / p) - offset | ||||||||
| } | ||||||||
| } | ||||||||
| trans_new( | ||||||||
| paste0("pow-", format(p)), trans, inv | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @rdname boxcox_trans | ||||||||
| #' @export | ||||||||
| modulus_trans <- function(p, offset = 1) { | ||||||||
| if (abs(p) < 1e-07) { | ||||||||
| trans <- function(x) sign(x) * log(abs(x) + offset) | ||||||||
| inv <- function(x) sign(x) * (exp(abs(x)) - offset) | ||||||||
| } else { | ||||||||
| trans <- function(x) sign(x) * ((abs(x) + offset)^p - 1) / p | ||||||||
| inv <- function(x) sign(x) * ((abs(x) * p + 1)^(1 / p) - offset) | ||||||||
| } | ||||||||
| trans_new( | ||||||||
| paste0("mt-pow-", format(p)), trans, inv | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Yeo-Johnson transformation | ||||||||
| #' | ||||||||
| #' The Yeo-Johnson transformation is a flexible transformation that is similiar | ||||||||
| #' to Box-Cox, [boxcox_trans()], but does not require input values to be greater | ||||||||
| #' than zero. | ||||||||
| #' | ||||||||
| #' The transformation takes one of four forms depending on the values of `y` and \eqn{\lambda}. | ||||||||
| #' | ||||||||
| #' * \eqn{y \ge 0} and \eqn{\lambda \neq 0}{\lambda != 0} : | ||||||||
| #' \eqn{y^{(\lambda)} = \frac{(y + 1)^\lambda - 1}{\lambda}}{y^(\lambda) = ((y + 1)^\lambda - 1)/\lambda} | ||||||||
| #' * \eqn{y \ge 0} and \eqn{\lambda = 0}: | ||||||||
| #' \eqn{y^{(\lambda)} = \ln(y + 1)}{y^(\lambda) = ln(y + 1)} | ||||||||
| #' * \eqn{y < 0} and \eqn{\lambda \neq 2}{\lambda != 2}: | ||||||||
| #' \eqn{y^{(\lambda)} = -\frac{(-y + 1)^{(2 - \lambda)} - 1}{2 - \lambda}}{y^(\lambda) = -((-y + 1)^(2 - \lambda) - 1)/(2 - \lambda)} | ||||||||
| #' * \eqn{y < 0} and \eqn{\lambda = 2}: | ||||||||
| #' \eqn{y^{(\lambda)} = -\ln(-y + 1)}{y^(\lambda) = -ln(-y + 1)} | ||||||||
| #' | ||||||||
| #' @param p Transformation exponent, \eqn{\lambda}. | ||||||||
| #' @references Yeo, I., & Johnson, R. (2000). | ||||||||
| #' A New Family of Power Transformations to Improve Normality or Symmetry. Biometrika, 87(4), 954-959. | ||||||||
| #' \url{http://www.jstor.org/stable/2673623} | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' plot(yj_trans(-1), xlim = c(-10, 10)) | ||||||||
| #' plot(yj_trans(0), xlim = c(-10, 10)) | ||||||||
| #' plot(yj_trans(1), xlim = c(-10, 10)) | ||||||||
| #' plot(yj_trans(2), xlim = c(-10, 10)) | ||||||||
| yj_trans <- function(p) { | ||||||||
| eps <- 1e-7 | ||||||||
| if (abs(p) < eps) { | ||||||||
| trans_pos <- function(x) log(x + 1) | ||||||||
| inv_pos <- function(x) exp(x) - 1 | ||||||||
| } else { | ||||||||
| trans_pos <- function(x) ((x + 1)^p - 1) / p | ||||||||
| inv_pos <- function(x) (p*x + 1)^(1/p) - 1 | ||||||||
| } | ||||||||
| if (abs(2 - p) < eps) { | ||||||||
| trans_neg <- function(x) -log(-x + 1) | ||||||||
| inv_neg <- function(x) 1 - exp(-x) | ||||||||
| } else { | ||||||||
| trans_neg <- function(x) -((-x + 1)^(2 - p) - 1)/(2 - p) | ||||||||
| inv_neg <- function(x) 1 - (-(2 - p)*x + 1)^(1/(2 - p)) | ||||||||
| } | ||||||||
| trans_new( | ||||||||
| paste0("yeo-johnson-", format(p)), | ||||||||
| function(x) trans_two_sided(x, trans_pos, trans_neg), | ||||||||
| function(x) trans_two_sided(x, inv_pos, inv_neg) | ||||||||
| ) | ||||||||
| } | ||||||||
| trans_two_sided <- function(x, pos, neg) { | ||||||||
| out <- rep(NA_real_, length(x)) | ||||||||
| present <- !is.na(x) | ||||||||
| out[present & x > 0] <- pos(x[present & x > 0]) | ||||||||
| out[present & x < 0] <- neg(x[present & x < 0]) | ||||||||
| out[present & x == 0] <- 0 | ||||||||
| out | ||||||||
| } | ||||||||
| #' Exponential transformation (inverse of log transformation) | ||||||||
| #' | ||||||||
| #' @param base Base of logarithm | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' plot(exp_trans(0.5), xlim = c(-2, 2)) | ||||||||
| #' plot(exp_trans(1), xlim = c(-2, 2)) | ||||||||
| #' plot(exp_trans(2), xlim = c(-2, 2)) | ||||||||
| #' plot(exp_trans(), xlim = c(-2, 2)) | ||||||||
| exp_trans <- function(base = exp(1)) { | ||||||||
| force(base) | ||||||||
| trans_new( | ||||||||
| paste0("power-", format(base)), | ||||||||
| function(x) base^x, | ||||||||
| function(x) log(x, base = base) | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Identity transformation (do nothing) | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' plot(identity_trans(), xlim = c(-1, 1)) | ||||||||
| identity_trans <- function() { | ||||||||
| trans_new("identity", "force", "force") | ||||||||
| } | ||||||||
| #' Log transformations | ||||||||
| #' | ||||||||
| #' * `log_trans()`: `log(x)` | ||||||||
| #' * `log1p()`: `log(x + 1)` | ||||||||
| #' * `pseudo_log_trans()`: smoothly transition to linear scale around 0. | ||||||||
| #' | ||||||||
| #' @param base base of logarithm | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' plot(log2_trans(), xlim = c(0, 5)) | ||||||||
| #' plot(log_trans(), xlim = c(0, 5)) | ||||||||
| #' plot(log10_trans(), xlim = c(0, 5)) | ||||||||
| #' | ||||||||
| #' plot(log_trans(), xlim = c(0, 2)) | ||||||||
| #' plot(log1p_trans(), xlim = c(-1, 1)) | ||||||||
| #' | ||||||||
| #' # The pseudo-log is defined for all real numbers | ||||||||
| #' plot(pseudo_log_trans(), xlim = c(-5, 5)) | ||||||||
| #' lines(log_trans(), xlim = c(0, 5), col = "red") | ||||||||
| #' | ||||||||
| #' # For large positives nubmers it's very close to log | ||||||||
| #' plot(pseudo_log_trans(), xlim = c(1, 20)) | ||||||||
| #' lines(log_trans(), xlim = c(1, 20), col = "red") | ||||||||
| log_trans <- function(base = exp(1)) { | ||||||||
| force(base) | ||||||||
| trans <- function(x) log(x, base) | ||||||||
| inv <- function(x) base^x | ||||||||
| trans_new(paste0("log-", format(base)), trans, inv, | ||||||||
| log_breaks(base = base), | ||||||||
| domain = c(1e-100, Inf) | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname log_trans | ||||||||
| log10_trans <- function() { | ||||||||
| log_trans(10) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname log_trans | ||||||||
| log2_trans <- function() { | ||||||||
| log_trans(2) | ||||||||
| } | ||||||||
| #' @rdname log_trans | ||||||||
| #' @export | ||||||||
| log1p_trans <- function() { | ||||||||
| trans_new("log1p", "log1p", "expm1") | ||||||||
| } | ||||||||
| #' @rdname log_trans | ||||||||
| #' @param sigma Scaling factor for the linear part of pseudo-log transformation. | ||||||||
| #' @export | ||||||||
| pseudo_log_trans <- function(sigma = 1, base = exp(1)) { | ||||||||
| trans_new( | ||||||||
| "pseudo_log", | ||||||||
| function(x) asinh(x / (2 * sigma)) / log(base), | ||||||||
| function(x) 2 * sigma * sinh(x * log(base)) | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Probability transformation | ||||||||
| #' | ||||||||
| #' @param distribution probability distribution. Should be standard R | ||||||||
| #' abbreviation so that "p" + distribution is a valid probability density | ||||||||
| #' function, and "q" + distribution is a valid quantile function. | ||||||||
| #' @param ... other arguments passed on to distribution and quantile functions | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' plot(logit_trans(), xlim = c(0, 1)) | ||||||||
| #' plot(probit_trans(), xlim = c(0, 1)) | ||||||||
| probability_trans <- function(distribution, ...) { | ||||||||
| qfun <- match.fun(paste0("q", distribution)) | ||||||||
| pfun <- match.fun(paste0("p", distribution)) | ||||||||
| trans_new( | ||||||||
| paste0("prob-", distribution), | ||||||||
| function(x) qfun(x, ...), | ||||||||
| function(x) pfun(x, ...) | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname probability_trans | ||||||||
| logit_trans <- function() probability_trans("logis") | ||||||||
| #' @export | ||||||||
| #' @rdname probability_trans | ||||||||
| probit_trans <- function() probability_trans("norm") | ||||||||
| #' Reciprocal transformation | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' plot(reciprocal_trans(), xlim = c(0, 1)) | ||||||||
| reciprocal_trans <- function() { | ||||||||
| trans_new( | ||||||||
| "reciprocal", | ||||||||
| function(x) 1 / x, | ||||||||
| function(x) 1 / x | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Reverse transformation | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' plot(reverse_trans(), xlim = c(-1, 1)) | ||||||||
| reverse_trans <- function() { | ||||||||
| trans_new( | ||||||||
| "reverse", | ||||||||
| function(x) -x, | ||||||||
| function(x) -x, | ||||||||
| minor_breaks = regular_minor_breaks(reverse = TRUE) | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Square-root transformation | ||||||||
| #' | ||||||||
| #' This is the variance stabilising transformation for the Poisson | ||||||||
| #' distribution. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' plot(sqrt_trans(), xlim = c(0, 5)) | ||||||||
| sqrt_trans <- function() { | ||||||||
| trans_new( | ||||||||
| "sqrt", | ||||||||
| "sqrt", | ||||||||
| function(x) x ^ 2, | ||||||||
| domain = c(0, Inf) | ||||||||
| ) | ||||||||
| } | ||||||||
| ggplot2/R/scale-.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Continuous scale constructor | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @param aesthetics The names of the aesthetics that this scale works with. | ||||||||
| #' @param scale_name The name of the scale that should be used for error messages | ||||||||
| #' associated with this scale. | ||||||||
| #' @param palette A palette function that when called with a numeric vector with | ||||||||
| #' values between 0 and 1 returns the corresponding output values | ||||||||
| #' (e.g., [scales::area_pal()]). | ||||||||
| #' @param name The name of the scale. Used as the axis or legend title. If | ||||||||
| #' `waiver()`, the default, the name of the scale is taken from the first | ||||||||
| #' mapping used for that aesthetic. If `NULL`, the legend title will be | ||||||||
| #' omitted. | ||||||||
| #' @param breaks One of: | ||||||||
| #' - `NULL` for no breaks | ||||||||
| #' - `waiver()` for the default breaks computed by the | ||||||||
| #' [transformation object][scales::trans_new()] | ||||||||
| #' - A numeric vector of positions | ||||||||
| #' - A function that takes the limits as input and returns breaks | ||||||||
| #' as output (e.g., a function returned by [scales::extended_breaks()]) | ||||||||
| #' @param minor_breaks One of: | ||||||||
| #' - `NULL` for no minor breaks | ||||||||
| #' - `waiver()` for the default breaks (one minor break between | ||||||||
| #' each major break) | ||||||||
| #' - A numeric vector of positions | ||||||||
| #' - A function that given the limits returns a vector of minor breaks. | ||||||||
| #' @param n.breaks An integer guiding the number of major breaks. The algorithm | ||||||||
| #' may choose a slightly different number to ensure nice break labels. Will | ||||||||
| #' only have an effect if `breaks = waiver()`. Use `NULL` to use the default | ||||||||
| #' number of breaks given by the transformation. | ||||||||
| #' @param labels One of: | ||||||||
| #' - `NULL` for no labels | ||||||||
| #' - `waiver()` for the default labels computed by the | ||||||||
| #' transformation object | ||||||||
| #' - A character vector giving labels (must be same length as `breaks`) | ||||||||
| #' - A function that takes the breaks as input and returns labels | ||||||||
| #' as output | ||||||||
| #' @param limits One of: | ||||||||
| #' - `NULL` to use the default scale range | ||||||||
| #' - A numeric vector of length two providing limits of the scale. | ||||||||
| #' Use `NA` to refer to the existing minimum or maximum | ||||||||
| #' - A function that accepts the existing (automatic) limits and returns | ||||||||
| #' new limits | ||||||||
| #' Note that setting limits on positional scales will **remove** data outside of the limits. | ||||||||
| #' If the purpose is to zoom, use the limit argument in the coordinate system | ||||||||
| #' (see [coord_cartesian()]). | ||||||||
| #' @param rescaler A function used to scale the input values to the | ||||||||
| #' range \[0, 1]. This is always [scales::rescale()], except for | ||||||||
| #' diverging and n colour gradients (i.e., [scale_colour_gradient2()], | ||||||||
| #' [scale_colour_gradientn()]). The `rescaler` is ignored by position | ||||||||
| #' scales, which always use [scales::rescale()]. | ||||||||
| #' @param oob One of: | ||||||||
| #' - Function that handles limits outside of the scale limits | ||||||||
| #' (out of bounds). | ||||||||
| #' - The default ([scales::censor()]) replaces out of | ||||||||
| #' bounds values with `NA`. | ||||||||
| #' - [scales::squish()] for squishing out of bounds values into range. | ||||||||
| #' - [scales::squish_infinite()] for squishing infinite values into range. | ||||||||
| #' @param na.value Missing values will be replaced with this value. | ||||||||
| #' @param trans For continuous scales, the name of a transformation object | ||||||||
| #' or the object itself. Built-in transformations include "asn", "atanh", | ||||||||
| #' "boxcox", "date", "exp", "hms", "identity", "log", "log10", "log1p", "log2", | ||||||||
| #' "logit", "modulus", "probability", "probit", "pseudo_log", "reciprocal", | ||||||||
| #' "reverse", "sqrt" and "time". | ||||||||
| #' | ||||||||
| #' A transformation object bundles together a transform, its inverse, | ||||||||
| #' and methods for generating breaks and labels. Transformation objects | ||||||||
| #' are defined in the scales package, and are called `<name>_trans` (e.g., | ||||||||
| #' [scales::boxcox_trans()]). You can create your own | ||||||||
| #' transformation with [scales::trans_new()]. | ||||||||
| #' @param guide A function used to create a guide or its name. See | ||||||||
| #' [guides()] for more information. | ||||||||
| #' @param expand For position scales, a vector of range expansion constants used to add some | ||||||||
| #' padding around the data to ensure that they are placed some distance | ||||||||
| #' away from the axes. Use the convenience function [expansion()] | ||||||||
| #' to generate the values for the `expand` argument. The defaults are to | ||||||||
| #' expand the scale by 5% on each side for continuous variables, and by | ||||||||
| #' 0.6 units on each side for discrete variables. | ||||||||
| #' @param position For position scales, The position of the axis. | ||||||||
| #' `left` or `right` for y axes, `top` or `bottom` for x axes. | ||||||||
| #' @param super The super class to use for the constructed scale | ||||||||
| #' @keywords internal | ||||||||
| continuous_scale <- function(aesthetics, scale_name, palette, name = waiver(), | ||||||||
| breaks = waiver(), minor_breaks = waiver(), n.breaks = NULL, | ||||||||
| labels = waiver(), limits = NULL, rescaler = rescale, | ||||||||
| oob = censor, expand = waiver(), na.value = NA_real_, | ||||||||
| trans = "identity", guide = "legend", position = "left", | ||||||||
| super = ScaleContinuous) { | ||||||||
| aesthetics <- standardise_aes_names(aesthetics) | ||||||||
| check_breaks_labels(breaks, labels) | ||||||||
| position <- match.arg(position, c("left", "right", "top", "bottom")) | ||||||||
| # If the scale is non-positional, break = NULL means removing the guide | ||||||||
| if (is.null(breaks) && all(!is_position_aes(aesthetics))) { | ||||||||
| guide <- "none" | ||||||||
| } | ||||||||
| trans <- as.trans(trans) | ||||||||
| if (!is.null(limits) && !is.function(limits)) { | ||||||||
| limits <- trans$transform(limits) | ||||||||
| } | ||||||||
| ggproto(NULL, super, | ||||||||
| call = match.call(), | ||||||||
| aesthetics = aesthetics, | ||||||||
| scale_name = scale_name, | ||||||||
| palette = palette, | ||||||||
| range = continuous_range(), | ||||||||
| limits = limits, | ||||||||
| trans = trans, | ||||||||
| na.value = na.value, | ||||||||
| expand = expand, | ||||||||
| rescaler = rescaler, | ||||||||
| oob = oob, | ||||||||
| name = name, | ||||||||
| breaks = breaks, | ||||||||
| minor_breaks = minor_breaks, | ||||||||
| n.breaks = n.breaks, | ||||||||
| labels = labels, | ||||||||
| guide = guide, | ||||||||
| position = position | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Discrete scale constructor | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @inheritParams continuous_scale | ||||||||
| #' @param palette A palette function that when called with a single integer | ||||||||
| #' argument (the number of levels in the scale) returns the values that | ||||||||
| #' they should take (e.g., [scales::hue_pal()]). | ||||||||
| #' @param breaks One of: | ||||||||
| #' - `NULL` for no breaks | ||||||||
| #' - `waiver()` for the default breaks (the scale limits) | ||||||||
| #' - A character vector of breaks | ||||||||
| #' - A function that takes the limits as input and returns breaks | ||||||||
| #' as output | ||||||||
| #' @param limits One of: | ||||||||
| #' - `NULL` to use the default scale values | ||||||||
| #' - A character vector that defines possible values of the scale and their | ||||||||
| #' order | ||||||||
| #' - A function that accepts the existing (automatic) values and returns | ||||||||
| #' new ones | ||||||||
| #' @param drop Should unused factor levels be omitted from the scale? | ||||||||
| #' The default, `TRUE`, uses the levels that appear in the data; | ||||||||
| #' `FALSE` uses all the levels in the factor. | ||||||||
| #' @param na.translate Unlike continuous scales, discrete scales can easily show | ||||||||
| #' missing values, and do so by default. If you want to remove missing values | ||||||||
| #' from a discrete scale, specify `na.translate = FALSE`. | ||||||||
| #' @param na.value If `na.translate = TRUE`, what aesthetic value should the | ||||||||
| #' missing values be displayed as? Does not apply to position scales | ||||||||
| #' where `NA` is always placed at the far right. | ||||||||
| #' @keywords internal | ||||||||
| discrete_scale <- function(aesthetics, scale_name, palette, name = waiver(), | ||||||||
| breaks = waiver(), labels = waiver(), limits = NULL, expand = waiver(), | ||||||||
| na.translate = TRUE, na.value = NA, drop = TRUE, | ||||||||
| guide = "legend", position = "left", super = ScaleDiscrete) { | ||||||||
| aesthetics <- standardise_aes_names(aesthetics) | ||||||||
| check_breaks_labels(breaks, labels) | ||||||||
| if (!is.function(limits) && (length(limits) > 0) && !is.discrete(limits)) { | ||||||||
| warn( | ||||||||
| glue( | ||||||||
| " | ||||||||
| Continuous limits supplied to discrete scale. | ||||||||
| Did you mean `limits = factor(...)` or `scale_*_continuous()`?" | ||||||||
| ) | ||||||||
| ) | ||||||||
| } | ||||||||
| position <- match.arg(position, c("left", "right", "top", "bottom")) | ||||||||
| # If the scale is non-positional, break = NULL means removing the guide | ||||||||
| if (is.null(breaks) && all(!is_position_aes(aesthetics))) { | ||||||||
| guide <- "none" | ||||||||
| } | ||||||||
| ggproto(NULL, super, | ||||||||
| call = match.call(), | ||||||||
| aesthetics = aesthetics, | ||||||||
| scale_name = scale_name, | ||||||||
| palette = palette, | ||||||||
| range = discrete_range(), | ||||||||
| limits = limits, | ||||||||
| na.value = na.value, | ||||||||
| na.translate = na.translate, | ||||||||
| expand = expand, | ||||||||
| name = name, | ||||||||
| breaks = breaks, | ||||||||
| labels = labels, | ||||||||
| drop = drop, | ||||||||
| guide = guide, | ||||||||
| position = position | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Binning scale constructor | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @inheritParams continuous_scale | ||||||||
| #' @param n.breaks The number of break points to create if breaks are not given | ||||||||
| #' directly. | ||||||||
| #' @param nice.breaks Logical. Should breaks be attempted placed at nice values | ||||||||
| #' instead of exactly evenly spaced between the limits. If `TRUE` (default) | ||||||||
| #' the scale will ask the transformation object to create breaks, and this | ||||||||
| #' may result in a different number of breaks than requested. Ignored if | ||||||||
| #' breaks are given explicetly. | ||||||||
| #' @param right Should values on the border between bins be part of the right | ||||||||
| #' (upper) bin? | ||||||||
| #' @param show.limits should the limits of the scale appear as ticks | ||||||||
| #' @keywords internal | ||||||||
| binned_scale <- function(aesthetics, scale_name, palette, name = waiver(), | ||||||||
| breaks = waiver(), labels = waiver(), limits = NULL, | ||||||||
| rescaler = rescale, oob = squish, expand = waiver(), | ||||||||
| na.value = NA_real_, n.breaks = NULL, nice.breaks = TRUE, | ||||||||
| right = TRUE, trans = "identity", show.limits = FALSE, | ||||||||
| guide = "bins", position = "left", super = ScaleBinned) { | ||||||||
| aesthetics <- standardise_aes_names(aesthetics) | ||||||||
| check_breaks_labels(breaks, labels) | ||||||||
| position <- match.arg(position, c("left", "right", "top", "bottom")) | ||||||||
| if (is.null(breaks) && !is_position_aes(aesthetics) && guide != "none") { | ||||||||
| guide <- "none" | ||||||||
| } | ||||||||
| trans <- as.trans(trans) | ||||||||
| if (!is.null(limits)) { | ||||||||
| limits <- trans$transform(limits) | ||||||||
| } | ||||||||
| ggproto(NULL, super, | ||||||||
| call = match.call(), | ||||||||
| aesthetics = aesthetics, | ||||||||
| scale_name = scale_name, | ||||||||
| palette = palette, | ||||||||
| range = continuous_range(), | ||||||||
| limits = limits, | ||||||||
| trans = trans, | ||||||||
| na.value = na.value, | ||||||||
| expand = expand, | ||||||||
| rescaler = rescaler, | ||||||||
| oob = oob, | ||||||||
| n.breaks = n.breaks, | ||||||||
| nice.breaks = nice.breaks, | ||||||||
| right = right, | ||||||||
| show.limits = show.limits, | ||||||||
| name = name, | ||||||||
| breaks = breaks, | ||||||||
| labels = labels, | ||||||||
| guide = guide, | ||||||||
| position = position | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @section Scales: | ||||||||
| #' | ||||||||
| #' All `scale_*` functions like [scale_x_continuous()] return a `Scale*` | ||||||||
| #' object like `ScaleContinuous`. Each of the `Scale*` objects is a [ggproto()] | ||||||||
| #' object, descended from the top-level `Scale`. | ||||||||
| #' | ||||||||
| #' Properties not documented in [continuous_scale()] or [discrete_scale()]: | ||||||||
| #' | ||||||||
| #' - `call` The call to [continuous_scale()] or [discrete_scale()] that constructed | ||||||||
| #' the scale. | ||||||||
| #' | ||||||||
| #' - `range` One of `continuous_range()` or `discrete_range()`. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' Methods: | ||||||||
| #' | ||||||||
| #' - `is_discrete()` Returns `TRUE` if the scale is a discrete scale | ||||||||
| #' | ||||||||
| #' - `is_empty()` Returns `TRUE` if the scale contains no information (i.e., | ||||||||
| #' it has no information with which to calculate its `limits`). | ||||||||
| #' | ||||||||
| #' - `clone()` Returns a copy of the scale that can be trained | ||||||||
| #' independently without affecting the original scale. | ||||||||
| #' | ||||||||
| #' - `transform()` Transforms a vector of values using `self$trans`. | ||||||||
| #' This occurs before the `Stat` is calculated. | ||||||||
| #' | ||||||||
| #' - `train()` Update the `self$range` of observed (transformed) data values with | ||||||||
| #' a vector of (possibly) new values. | ||||||||
| #' | ||||||||
| #' - `reset()` Reset the `self$range` of observed data values. For discrete | ||||||||
| #' position scales, only the continuous range is reset. | ||||||||
| #' | ||||||||
| #' - `map()` Map transformed data values to some output value as | ||||||||
| #' determined by `self$rescale()` and `self$palette` (except for position scales, | ||||||||
| #' which do not use the default implementation of this method). The output corresponds | ||||||||
| #' to the transformed data value in aesthetic space (e.g., a color, line width, or size). | ||||||||
| #' | ||||||||
| #' - `rescale()` Rescale transformed data to the the range 0, 1. This is most useful for | ||||||||
| #' position scales. For continuous scales, `rescale()` uses the `rescaler` that | ||||||||
| #' was provided to the constructor. `rescale()` does not apply `self$oob()` to | ||||||||
| #' its input, which means that discrete values outside `limits` will be `NA`, and | ||||||||
| #' values that are outside `range` will have values less than 0 or greater than 1. | ||||||||
| #' This allows guides more control over how out-of-bounds values are displayed. | ||||||||
| #' | ||||||||
| #' - `transform_df()`, `train_df()`, `map_df()` These `_df` variants | ||||||||
| #' accept a data frame, and apply the `transform`, `train`, and `map` methods | ||||||||
| #' (respectively) to the columns whose names are in `self$aesthetics`. | ||||||||
| #' | ||||||||
| #' - `get_limits()` Calculates the final scale limits in transformed data space | ||||||||
| #' based on the combination of `self$limits` and/or the range of observed values | ||||||||
| #' (`self$range`). | ||||||||
| #' | ||||||||
| #' - `get_breaks()` Calculates the final scale breaks in transformed data space | ||||||||
| #' based on on the combination of `self$breaks`, `self$trans$breaks()` (for | ||||||||
| #' continuous scales), and `limits`. Breaks outside of `limits` are assigned | ||||||||
| #' a value of `NA` (continuous scales) or dropped (discrete scales). | ||||||||
| #' | ||||||||
| #' - `get_labels()` Calculates labels for a given set of (transformed) `breaks` | ||||||||
| #' based on the combination of `self$labels` and `breaks`. | ||||||||
| #' | ||||||||
| #' - `get_breaks_minor()` For continuous scales, calculates the final scale minor breaks | ||||||||
| #' in transformed data space based on the rescaled `breaks`, the value of `self$minor_breaks`, | ||||||||
| #' and the value of `self$trans$minor_breaks()`. Discrete scales always return `NULL`. | ||||||||
| #' | ||||||||
| #' - `make_title()` Hook to modify the title that is calculated during guide construction | ||||||||
| #' (for non-position scales) or when the `Layout` calculates the x and y labels | ||||||||
| #' (position scales). | ||||||||
| #' | ||||||||
| #' These methods are only valid for position (x and y) scales: | ||||||||
| #' | ||||||||
| #' - `dimension()` For continuous scales, the dimension is the same concept as the limits. | ||||||||
| #' For discrete scales, `dimension()` returns a continuous range, where the limits | ||||||||
| #' would be placed at integer positions. `dimension()` optionally expands | ||||||||
| #' this range given an expantion of length 4 (see [expansion()]). | ||||||||
| #' | ||||||||
| #' - `break_info()` Returns a `list()` with calculated values needed for the `Coord` | ||||||||
| #' to transform values in transformed data space. Axis and grid guides also use | ||||||||
| #' these values to draw guides. This is called with | ||||||||
| #' a (usually expanded) continuous range, such as that returned by `self$dimension()` | ||||||||
| #' (even for discrete scales). The list has components `major_source` | ||||||||
| #' (`self$get_breaks()` for continuous scales, or `seq_along(self$get_breaks())` | ||||||||
| #' for discrete scales), `major` (the rescaled value of `major_source`, ignoring | ||||||||
| #' `self$rescaler`), `minor` (the rescaled value of `minor_source`, ignoring | ||||||||
| #' `self$rescaler`), `range` (the range that was passed in to `break_info()`), | ||||||||
| #' `labels` (the label values, one for each element in `breaks`). | ||||||||
| #' | ||||||||
| #' - `axis_order()` One of `c("primary", "secondary")` or `c("secondary", "primary")` | ||||||||
| #' | ||||||||
| #' - `make_sec_title()` Hook to modify the title for the second axis that is calculated | ||||||||
| #' when the `Layout` calculates the x and y labels. | ||||||||
| #' | ||||||||
| #' @rdname ggplot2-ggproto | ||||||||
| #' @format NULL | ||||||||
| #' @usage NULL | ||||||||
| #' @export | ||||||||
| Scale <- ggproto("Scale", NULL, | ||||||||
| call = NULL, | ||||||||
| aesthetics = aes(), | ||||||||
| scale_name = NULL, | ||||||||
| palette = function() { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| range = ggproto(NULL, Range), | ||||||||
| limits = NULL, | ||||||||
| na.value = NA, | ||||||||
| expand = waiver(), | ||||||||
| name = waiver(), | ||||||||
| breaks = waiver(), | ||||||||
| labels = waiver(), | ||||||||
| guide = "legend", | ||||||||
| position = "left", | ||||||||
| is_discrete = function() { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| train_df = function(self, df) { | ||||||||
| if (empty(df)) return() | ||||||||
| aesthetics <- intersect(self$aesthetics, names(df)) | ||||||||
| for (aesthetic in aesthetics) { | ||||||||
| self$train(df[[aesthetic]]) | ||||||||
| } | ||||||||
| invisible() | ||||||||
| }, | ||||||||
| train = function(self, x) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| reset = function(self) { | ||||||||
| self$range$reset() | ||||||||
| }, | ||||||||
| is_empty = function(self) { | ||||||||
| is.null(self$range$range) && is.null(self$limits) | ||||||||
| }, | ||||||||
| transform_df = function(self, df) { | ||||||||
| if (empty(df)) { | ||||||||
| return() | ||||||||
| } | ||||||||
| aesthetics <- intersect(self$aesthetics, names(df)) | ||||||||
| if (length(aesthetics) == 0) { | ||||||||
| return() | ||||||||
| } | ||||||||
| lapply(df[aesthetics], self$transform) | ||||||||
| }, | ||||||||
| transform = function(self, x) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| map_df = function(self, df, i = NULL) { | ||||||||
| if (empty(df)) { | ||||||||
| return() | ||||||||
| } | ||||||||
| aesthetics <- intersect(self$aesthetics, names(df)) | ||||||||
| names(aesthetics) <- aesthetics | ||||||||
| if (length(aesthetics) == 0) { | ||||||||
| return() | ||||||||
| } | ||||||||
| if (is.null(i)) { | ||||||||
| lapply(aesthetics, function(j) self$map(df[[j]])) | ||||||||
| } else { | ||||||||
| lapply(aesthetics, function(j) self$map(df[[j]][i])) | ||||||||
| } | ||||||||
| }, | ||||||||
| map = function(self, x, limits = self$get_limits()) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| rescale = function(self, x, limits = self$get_limits(), range = self$dimension()) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| get_limits = function(self) { | ||||||||
| if (self$is_empty()) { | ||||||||
| return(c(0, 1)) | ||||||||
| } | ||||||||
| if (is.null(self$limits)) { | ||||||||
| self$range$range | ||||||||
| } else if (is.function(self$limits)) { | ||||||||
| self$limits(self$range$range) | ||||||||
| } else { | ||||||||
| self$limits | ||||||||
| } | ||||||||
| }, | ||||||||
| dimension = function(self, expand = expansion(0, 0), limits = self$get_limits()) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| get_breaks = function(self, limits = self$get_limits()) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| break_positions = function(self, range = self$get_limits()) { | ||||||||
| self$map(self$get_breaks(range)) | ||||||||
| }, | ||||||||
| get_breaks_minor = function(self, n = 2, b = self$break_positions(), limits = self$get_limits()) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| get_labels = function(self, breaks = self$get_breaks()) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| clone = function(self) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| break_info = function(self, range = NULL) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| axis_order = function(self) { | ||||||||
| ord <- c("primary", "secondary") | ||||||||
| if (self$position %in% c("right", "bottom")) { | ||||||||
| ord <- rev(ord) | ||||||||
| } | ||||||||
| ord | ||||||||
| }, | ||||||||
| make_title = function(title) { | ||||||||
| title | ||||||||
| }, | ||||||||
| make_sec_title = function(title) { | ||||||||
| title | ||||||||
| } | ||||||||
| ) | ||||||||
| check_breaks_labels <- function(breaks, labels) { | ||||||||
| if (is.null(breaks)) { | ||||||||
| return(TRUE) | ||||||||
| } | ||||||||
| if (is.null(labels)) { | ||||||||
| return(TRUE) | ||||||||
| } | ||||||||
| bad_labels <- is.atomic(breaks) && is.atomic(labels) && | ||||||||
| length(breaks) != length(labels) | ||||||||
| if (bad_labels) { | ||||||||
| abort("`breaks` and `labels` must have the same length") | ||||||||
| } | ||||||||
| TRUE | ||||||||
| } | ||||||||
| #' @rdname ggplot2-ggproto | ||||||||
| #' @format NULL | ||||||||
| #' @usage NULL | ||||||||
| #' @export | ||||||||
| ScaleContinuous <- ggproto("ScaleContinuous", Scale, | ||||||||
| range = continuous_range(), | ||||||||
| na.value = NA_real_, | ||||||||
| rescaler = rescale, | ||||||||
| oob = censor, | ||||||||
| minor_breaks = waiver(), | ||||||||
| n.breaks = NULL, | ||||||||
| trans = identity_trans(), | ||||||||
| is_discrete = function() FALSE, | ||||||||
| train = function(self, x) { | ||||||||
| if (length(x) == 0) { | ||||||||
| return() | ||||||||
| } | ||||||||
| self$range$train(x) | ||||||||
| }, | ||||||||
| is_empty = function(self) { | ||||||||
| has_data <- !is.null(self$range$range) | ||||||||
| has_limits <- is.function(self$limits) || (!is.null(self$limits) && all(is.finite(self$limits))) | ||||||||
| !has_data && !has_limits | ||||||||
| }, | ||||||||
| transform = function(self, x) { | ||||||||
| new_x <- self$trans$transform(x) | ||||||||
| axis <- if ("x" %in% self$aesthetics) "x" else "y" | ||||||||
| check_transformation(x, new_x, self$scale_name, axis) | ||||||||
| new_x | ||||||||
| }, | ||||||||
| map = function(self, x, limits = self$get_limits()) { | ||||||||
| x <- self$rescale(self$oob(x, range = limits), limits) | ||||||||
| uniq <- unique(x) | ||||||||
| pal <- self$palette(uniq) | ||||||||
| scaled <- pal[match(x, uniq)] | ||||||||
| ifelse(!is.na(scaled), scaled, self$na.value) | ||||||||
| }, | ||||||||
| rescale = function(self, x, limits = self$get_limits(), range = limits) { | ||||||||
| self$rescaler(x, from = range) | ||||||||
| }, | ||||||||
| get_limits = function(self) { | ||||||||
| if (self$is_empty()) { | ||||||||
| return(c(0, 1)) | ||||||||
| } | ||||||||
| if (is.null(self$limits)) { | ||||||||
| self$range$range | ||||||||
| } else if (is.function(self$limits)) { | ||||||||
| # if limits is a function, it expects to work in data space | ||||||||
| self$trans$transform(self$limits(self$trans$inverse(self$range$range))) | ||||||||
| } else { | ||||||||
| # NA limits for a continuous scale mean replace with the min/max of data | ||||||||
| ifelse(is.na(self$limits), self$range$range, self$limits) | ||||||||
| } | ||||||||
| }, | ||||||||
| dimension = function(self, expand = expansion(0, 0), limits = self$get_limits()) { | ||||||||
| expand_limits_scale(self, expand, limits) | ||||||||
| }, | ||||||||
| get_breaks = function(self, limits = self$get_limits()) { | ||||||||
| if (self$is_empty()) { | ||||||||
| return(numeric()) | ||||||||
| } | ||||||||
| # Limits in transformed space need to be converted back to data space | ||||||||
| limits <- self$trans$inverse(limits) | ||||||||
| if (is.null(self$breaks)) { | ||||||||
| return(NULL) | ||||||||
| } | ||||||||
| if (identical(self$breaks, NA)) { | ||||||||
| abort("Invalid breaks specification. Use NULL, not NA") | ||||||||
| } | ||||||||
| if (zero_range(as.numeric(limits))) { | ||||||||
| breaks <- limits[1] | ||||||||
| } else if (is.waive(self$breaks)) { | ||||||||
| if (!is.null(self$n.breaks) && trans_support_nbreaks(self$trans)) { | ||||||||
| breaks <- self$trans$breaks(limits, self$n.breaks) | ||||||||
| } else { | ||||||||
| if (!is.null(self$n.breaks)) { | ||||||||
| warn("Ignoring n.breaks. Use a trans object that supports setting number of breaks") | ||||||||
| } | ||||||||
| breaks <- self$trans$breaks(limits) | ||||||||
| } | ||||||||
| } else if (is.function(self$breaks)) { | ||||||||
| breaks <- self$breaks(limits) | ||||||||
| } else { | ||||||||
| breaks <- self$breaks | ||||||||
| } | ||||||||
| # Breaks in data space need to be converted back to transformed space | ||||||||
| breaks <- self$trans$transform(breaks) | ||||||||
| # Any breaks outside the dimensions are flagged as missing | ||||||||
| breaks <- censor(breaks, self$trans$transform(limits), only.finite = FALSE) | ||||||||
| breaks | ||||||||
| }, | ||||||||
| get_breaks_minor = function(self, n = 2, b = self$break_positions(), limits = self$get_limits()) { | ||||||||
| if (zero_range(as.numeric(limits))) { | ||||||||
| return() | ||||||||
| } | ||||||||
| if (is.null(self$minor_breaks)) { | ||||||||
| return(NULL) | ||||||||
| } | ||||||||
| if (identical(self$minor_breaks, NA)) { | ||||||||
| abort("Invalid minor_breaks specification. Use NULL, not NA") | ||||||||
| } | ||||||||
| if (is.waive(self$minor_breaks)) { | ||||||||
| if (is.null(b)) { | ||||||||
| breaks <- NULL | ||||||||
| } else { | ||||||||
| breaks <- self$trans$minor_breaks(b, limits, n) | ||||||||
| } | ||||||||
| } else if (is.function(self$minor_breaks)) { | ||||||||
| # Find breaks in data space, and convert to numeric | ||||||||
| breaks <- self$minor_breaks(self$trans$inverse(limits)) | ||||||||
| breaks <- self$trans$transform(breaks) | ||||||||
| } else { | ||||||||
| breaks <- self$trans$transform(self$minor_breaks) | ||||||||
| } | ||||||||
| # Any minor breaks outside the dimensions need to be thrown away | ||||||||
| discard(breaks, limits) | ||||||||
| }, | ||||||||
| get_labels = function(self, breaks = self$get_breaks()) { | ||||||||
| if (is.null(breaks)) { | ||||||||
| return(NULL) | ||||||||
| } | ||||||||
| breaks <- self$trans$inverse(breaks) | ||||||||
| if (is.null(self$labels)) { | ||||||||
| return(NULL) | ||||||||
| } | ||||||||
| if (identical(self$labels, NA)) { | ||||||||
| abort("Invalid labels specification. Use NULL, not NA") | ||||||||
| } | ||||||||
| if (is.waive(self$labels)) { | ||||||||
| labels <- self$trans$format(breaks) | ||||||||
| } else if (is.function(self$labels)) { | ||||||||
| labels <- self$labels(breaks) | ||||||||
| } else { | ||||||||
| labels <- self$labels | ||||||||
| } | ||||||||
| if (length(labels) != length(breaks)) { | ||||||||
| abort("Breaks and labels are different lengths") | ||||||||
| } | ||||||||
| if (is.list(labels)) { | ||||||||
| # Guard against list with empty elements | ||||||||
| labels[vapply(labels, length, integer(1)) == 0] <- "" | ||||||||
| # Make sure each element is scalar | ||||||||
| labels <- lapply(labels, `[`, 1) | ||||||||
| if (any(vapply(labels, is.language, logical(1)))) { | ||||||||
| labels <- do.call(expression, labels) | ||||||||
| } else { | ||||||||
| labels <- unlist(labels) | ||||||||
| } | ||||||||
| } | ||||||||
| labels | ||||||||
| }, | ||||||||
| clone = function(self) { | ||||||||
| new <- ggproto(NULL, self) | ||||||||
| new$range <- continuous_range() | ||||||||
| new | ||||||||
| }, | ||||||||
| break_info = function(self, range = NULL) { | ||||||||
| # range | ||||||||
| if (is.null(range)) range <- self$dimension() | ||||||||
| # major breaks | ||||||||
| major <- self$get_breaks(range) | ||||||||
| # labels | ||||||||
| labels <- self$get_labels(major) | ||||||||
| # drop oob breaks/labels by testing major == NA | ||||||||
| if (!is.null(labels)) labels <- labels[!is.na(major)] | ||||||||
| if (!is.null(major)) major <- major[!is.na(major)] | ||||||||
| # minor breaks | ||||||||
| minor <- self$get_breaks_minor(b = major, limits = range) | ||||||||
| if (!is.null(minor)) minor <- minor[!is.na(minor)] | ||||||||
| # rescale breaks [0, 1], which are used by coord/guide | ||||||||
| major_n <- rescale(major, from = range) | ||||||||
| minor_n <- rescale(minor, from = range) | ||||||||
| list( | ||||||||
| range = range, | ||||||||
| labels = labels, | ||||||||
| major = major_n, | ||||||||
| minor = minor_n, | ||||||||
| major_source = major, | ||||||||
| minor_source = minor | ||||||||
| ) | ||||||||
| }, | ||||||||
| print = function(self, ...) { | ||||||||
| show_range <- function(x) paste0(formatC(x, digits = 3), collapse = " -- ") | ||||||||
| cat("<", class(self)[[1]], ">\n", sep = "") | ||||||||
| cat(" Range: ", show_range(self$range$range), "\n", sep = "") | ||||||||
| if (is.function(self$limits)) { | ||||||||
| cat(" Limits: function()\n") | ||||||||
| } else { | ||||||||
| cat(" Limits: ", show_range(self$dimension()), "\n", sep = "") | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @rdname ggplot2-ggproto | ||||||||
| #' @format NULL | ||||||||
| #' @usage NULL | ||||||||
| #' @export | ||||||||
| ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, | ||||||||
| drop = TRUE, | ||||||||
| na.value = NA, | ||||||||
| n.breaks.cache = NULL, | ||||||||
| palette.cache = NULL, | ||||||||
| is_discrete = function() TRUE, | ||||||||
| train = function(self, x) { | ||||||||
| if (length(x) == 0) { | ||||||||
| return() | ||||||||
| } | ||||||||
| self$range$train(x, drop = self$drop, na.rm = !self$na.translate) | ||||||||
| }, | ||||||||
| transform = function(x) { | ||||||||
| x | ||||||||
| }, | ||||||||
| map = function(self, x, limits = self$get_limits()) { | ||||||||
| n <- sum(!is.na(limits)) | ||||||||
| if (!is.null(self$n.breaks.cache) && self$n.breaks.cache == n) { | ||||||||
| pal <- self$palette.cache | ||||||||
| } else { | ||||||||
| if (!is.null(self$n.breaks.cache)) { | ||||||||
| warn("Cached palette does not match requested") | ||||||||
| } | ||||||||
| pal <- self$palette(n) | ||||||||
| self$palette.cache <- pal | ||||||||
| self$n.breaks.cache <- n | ||||||||
| } | ||||||||
| if (is_named(pal)) { | ||||||||
| # if pal is named, limit the pal by the names first, | ||||||||
| # then limit the values by the pal | ||||||||
| idx_nomatch <- is.na(match(names(pal), limits)) | ||||||||
| pal[idx_nomatch] <- NA | ||||||||
| pal_match <- pal[match(as.character(x), names(pal))] | ||||||||
| pal_match <- unname(pal_match) | ||||||||
| } else { | ||||||||
| # if pal is not named, limit the values directly | ||||||||
| pal_match <- pal[match(as.character(x), limits)] | ||||||||
| } | ||||||||
| if (self$na.translate) { | ||||||||
| ifelse(is.na(x) | is.na(pal_match), self$na.value, pal_match) | ||||||||
| } else { | ||||||||
| pal_match | ||||||||
| } | ||||||||
| }, | ||||||||
| rescale = function(self, x, limits = self$get_limits(), range = c(1, length(limits))) { | ||||||||
| rescale(x, match(as.character(x), limits), from = range) | ||||||||
| }, | ||||||||
| dimension = function(self, expand = expansion(0, 0), limits = self$get_limits()) { | ||||||||
| expand_limits_discrete(limits, expand = expand) | ||||||||
| }, | ||||||||
| get_breaks = function(self, limits = self$get_limits()) { | ||||||||
| if (self$is_empty()) { | ||||||||
| return(numeric()) | ||||||||
| } | ||||||||
| if (is.null(self$breaks)) { | ||||||||
| return(NULL) | ||||||||
| } | ||||||||
| if (identical(self$breaks, NA)) { | ||||||||
| abort("Invalid breaks specification. Use NULL, not NA") | ||||||||
| } | ||||||||
| if (is.waive(self$breaks)) { | ||||||||
| breaks <- limits | ||||||||
| } else if (is.function(self$breaks)) { | ||||||||
| breaks <- self$breaks(limits) | ||||||||
| } else { | ||||||||
| breaks <- self$breaks | ||||||||
| } | ||||||||
| # Breaks only occur only on values in domain | ||||||||
| in_domain <- intersect(breaks, limits) | ||||||||
| structure(in_domain, pos = match(in_domain, breaks)) | ||||||||
| }, | ||||||||
| get_breaks_minor = function(...) NULL, | ||||||||
| get_labels = function(self, breaks = self$get_breaks()) { | ||||||||
| if (self$is_empty()) { | ||||||||
| return(character()) | ||||||||
| } | ||||||||
| if (is.null(breaks)) { | ||||||||
| return(NULL) | ||||||||
| } | ||||||||
| if (is.null(self$labels)) { | ||||||||
| return(NULL) | ||||||||
| } | ||||||||
| if (identical(self$labels, NA)) { | ||||||||
| abort("Invalid labels specification. Use NULL, not NA") | ||||||||
| } | ||||||||
| if (is.waive(self$labels)) { | ||||||||
| if (is.numeric(breaks)) { | ||||||||
| # Only format numbers, because on Windows, format messes up encoding | ||||||||
| format(breaks, justify = "none") | ||||||||
| } else { | ||||||||
| as.character(breaks) | ||||||||
| } | ||||||||
| } else if (is.function(self$labels)) { | ||||||||
| self$labels(breaks) | ||||||||
| } else { | ||||||||
| if (!is.null(names(self$labels))) { | ||||||||
| # If labels have names, use them to match with breaks | ||||||||
| labels <- breaks | ||||||||
| map <- match(names(self$labels), labels, nomatch = 0) | ||||||||
| labels[map] <- self$labels[map != 0] | ||||||||
| labels | ||||||||
| } else { | ||||||||
| labels <- self$labels | ||||||||
| # Need to ensure that if breaks were dropped, corresponding labels are too | ||||||||
| pos <- attr(breaks, "pos") | ||||||||
| if (!is.null(pos)) { | ||||||||
| labels <- labels[pos] | ||||||||
| } | ||||||||
| labels | ||||||||
| } | ||||||||
| } | ||||||||
| }, | ||||||||
| clone = function(self) { | ||||||||
| new <- ggproto(NULL, self) | ||||||||
| new$range <- discrete_range() | ||||||||
| new | ||||||||
| }, | ||||||||
| break_info = function(self, range = NULL) { | ||||||||
| # for discrete, limits != range | ||||||||
| limits <- self$get_limits() | ||||||||
| major <- self$get_breaks(limits) | ||||||||
| if (is.null(major)) { | ||||||||
| labels <- major_n <- NULL | ||||||||
| } else { | ||||||||
| labels <- self$get_labels(major) | ||||||||
| major <- self$map(major) | ||||||||
| major <- major[!is.na(major)] | ||||||||
| # rescale breaks [0, 1], which are used by coord/guide | ||||||||
| major_n <- rescale(major, from = range) | ||||||||
| } | ||||||||
| list( | ||||||||
| range = range, | ||||||||
| labels = labels, | ||||||||
| major = major_n, | ||||||||
| minor = NULL, | ||||||||
| major_source = major, | ||||||||
| minor_source = NULL | ||||||||
| ) | ||||||||
| } | ||||||||
| ) | ||||||||
| #' @rdname ggplot2-ggproto | ||||||||
| #' @format NULL | ||||||||
| #' @usage NULL | ||||||||
| #' @export | ||||||||
| ScaleBinned <- ggproto("ScaleBinned", Scale, | ||||||||
| range = continuous_range(), | ||||||||
| na.value = NA_real_, | ||||||||
| rescaler = rescale, | ||||||||
| oob = squish, | ||||||||
| n.breaks = NULL, | ||||||||
| nice.breaks = TRUE, | ||||||||
| right = TRUE, | ||||||||
| after.stat = FALSE, | ||||||||
| show.limits = FALSE, | ||||||||
| is_discrete = function() FALSE, | ||||||||
| train = function(self, x) { | ||||||||
| if (!is.numeric(x)) { | ||||||||
| abort("Binned scales only support continuous data") | ||||||||
| } | ||||||||
| if (length(x) == 0) { | ||||||||
| return() | ||||||||
| } | ||||||||
| self$range$train(x) | ||||||||
| }, | ||||||||
| transform = function(self, x) { | ||||||||
| new_x <- self$trans$transform(x) | ||||||||
| axis <- if ("x" %in% self$aesthetics) "x" else "y" | ||||||||
| check_transformation(x, new_x, self$scale_name, axis) | ||||||||
| new_x | ||||||||
| }, | ||||||||
| map = function(self, x, limits = self$get_limits()) { | ||||||||
| if (self$after.stat) { | ||||||||
| x | ||||||||
| } else { | ||||||||
| breaks <- self$get_breaks(limits) | ||||||||
| breaks <- sort(unique(c(limits[1], breaks, limits[2]))) | ||||||||
| x <- self$rescale(self$oob(x, range = limits), limits) | ||||||||
| breaks <- self$rescale(breaks, limits) | ||||||||
| x_binned <- cut(x, breaks, | ||||||||
| labels = FALSE, | ||||||||
| include.lowest = TRUE, | ||||||||
| right = self$right | ||||||||
| ) | ||||||||
| if (!is.null(self$palette.cache)) { | ||||||||
| pal <- self$palette.cache | ||||||||
| } else { | ||||||||
| pal <- self$palette(breaks[-1] - diff(breaks) / 2) | ||||||||
| self$palette.cache <- pal | ||||||||
| } | ||||||||
| scaled <- pal[x_binned] | ||||||||
| ifelse(!is.na(scaled), scaled, self$na.value) | ||||||||
| } | ||||||||
| }, | ||||||||
| rescale = function(self, x, limits = self$get_limits(), range = limits) { | ||||||||
| self$rescaler(x, from = range) | ||||||||
| }, | ||||||||
| dimension = function(self, expand = c(0, 0, 0, 0)) { | ||||||||
| expand_range4(self$get_limits(), expand) | ||||||||
| }, | ||||||||
| get_breaks = function(self, limits = self$get_limits()) { | ||||||||
| if (self$is_empty()) return(numeric()) | ||||||||
| limits <- self$trans$inverse(limits) | ||||||||
| if (is.null(self$breaks)) { | ||||||||
| return(NULL) | ||||||||
| } else if (identical(self$breaks, NA)) { | ||||||||
| abort("Invalid breaks specification. Use NULL, not NA") | ||||||||
| } else if (is.waive(self$breaks)) { | ||||||||
| if (self$nice.breaks) { | ||||||||
| if (!is.null(self$n.breaks) && trans_support_nbreaks(self$trans)) { | ||||||||
| breaks <- self$trans$breaks(limits, n = self$n.breaks) | ||||||||
| } else { | ||||||||
| if (!is.null(self$n.breaks)) { | ||||||||
| warn("Ignoring n.breaks. Use a trans object that supports setting number of breaks") | ||||||||
| } | ||||||||
| breaks <- self$trans$breaks(limits) | ||||||||
| } | ||||||||
| } else { | ||||||||
| n.breaks <- self$n.breaks %||% 5 # same default as trans objects | ||||||||
| breaks <- seq(limits[1], limits[2], length.out = n.breaks + 2) | ||||||||
| breaks <- breaks[-c(1, length(breaks))] | ||||||||
| } | ||||||||
| # Ensure terminal bins are same width if limits not set | ||||||||
| if (is.null(self$limits)) { | ||||||||
| # Remove calculated breaks if they coincide with limits | ||||||||
| breaks <- setdiff(breaks, limits) | ||||||||
| nbreaks <- length(breaks) | ||||||||
| if (nbreaks >= 2) { | ||||||||
| new_limits <- c(2 * breaks[1] - breaks[2], 2 * breaks[nbreaks] - breaks[nbreaks - 1]) | ||||||||
| if (breaks[nbreaks] > limits[2]) { | ||||||||
| new_limits[2] <- breaks[nbreaks] | ||||||||
| breaks <- breaks[-nbreaks] | ||||||||
| } | ||||||||
| if (breaks[1] < limits[1]) { | ||||||||
| new_limits[1] <- breaks[1] | ||||||||
| breaks <- breaks[-1] | ||||||||
| } | ||||||||
| limits <- new_limits | ||||||||
| } else { | ||||||||
| bin_size <- max(breaks[1] - limits[1], limits[2] - breaks[1]) | ||||||||
| limits <- c(breaks[1] - bin_size, breaks[1] + bin_size) | ||||||||
| } | ||||||||
| self$limits <- self$trans$transform(limits) | ||||||||
| } | ||||||||
| } else if (is.function(self$breaks)) { | ||||||||
| if ("n.breaks" %in% names(formals(environment(self$breaks)$f))) { | ||||||||
| n.breaks <- self$n.breaks %||% 5 # same default as trans objects | ||||||||
| breaks <- self$breaks(limits, n.breaks = n.breaks) | ||||||||
| } else { | ||||||||
| if (!is.null(self$n.breaks)) { | ||||||||
| warn("Ignoring n.breaks. Use a breaks function that supports setting number of breaks") | ||||||||
| } | ||||||||
| breaks <- self$breaks(limits) | ||||||||
| } | ||||||||
| } else { | ||||||||
| breaks <- self$breaks | ||||||||
| } | ||||||||
| # Breaks must be within limits | ||||||||
| breaks <- breaks[breaks >= limits[1] & breaks <= limits[2]] | ||||||||
| self$breaks <- breaks | ||||||||
| self$trans$transform(breaks) | ||||||||
| }, | ||||||||
| get_breaks_minor = function(...) NULL, | ||||||||
| get_labels = function(self, breaks = self$get_breaks()) { | ||||||||
| if (is.null(breaks)) return(NULL) | ||||||||
| breaks <- self$trans$inverse(breaks) | ||||||||
| if (is.null(self$labels)) { | ||||||||
| return(NULL) | ||||||||
| } else if (identical(self$labels, NA)) { | ||||||||
| abort("Invalid labels specification. Use NULL, not NA") | ||||||||
| } else if (is.waive(self$labels)) { | ||||||||
| labels <- self$trans$format(breaks) | ||||||||
| } else if (is.function(self$labels)) { | ||||||||
| labels <- self$labels(breaks) | ||||||||
| } else { | ||||||||
| labels <- self$labels | ||||||||
| } | ||||||||
| if (length(labels) != length(breaks)) { | ||||||||
| abort("Breaks and labels are different lengths") | ||||||||
| } | ||||||||
| labels | ||||||||
| }, | ||||||||
| clone = function(self) { | ||||||||
| new <- ggproto(NULL, self) | ||||||||
| new$range <- continuous_range() | ||||||||
| new | ||||||||
| }, | ||||||||
| break_info = function(self, range = NULL) { | ||||||||
| # range | ||||||||
| if (is.null(range)) range <- self$dimension() | ||||||||
| # major breaks | ||||||||
| major <- self$get_breaks(range) | ||||||||
| if (!is.null(self$palette.cache)) { | ||||||||
| pal <- self$palette.cache | ||||||||
| } else { | ||||||||
| pal <- self$palette(length(major) + 1) | ||||||||
| } | ||||||||
| if (self$show.limits) { | ||||||||
| limits <- self$get_limits() | ||||||||
| major <- sort(unique(c(limits, major))) | ||||||||
| } | ||||||||
| # labels | ||||||||
| labels <- self$get_labels(major) | ||||||||
| list(range = range, labels = labels, | ||||||||
| major = pal, minor = NULL, | ||||||||
| major_source = major, minor_source = NULL) | ||||||||
| } | ||||||||
| ) | ||||||||
| # In place modification of a scale to change the primary axis | ||||||||
| scale_flip_position <- function(scale) { | ||||||||
| scale$position <- switch(scale$position, | ||||||||
| top = "bottom", | ||||||||
| bottom = "top", | ||||||||
| left = "right", | ||||||||
| right = "left", | ||||||||
| scale$position | ||||||||
| ) | ||||||||
| invisible() | ||||||||
| } | ||||||||
| check_transformation <- function(x, transformed, name, axis) { | ||||||||
| if (any(is.finite(x) != is.finite(transformed))) { | ||||||||
| type <- if (name == "position_b") { | ||||||||
| "binned" | ||||||||
| } else if (name == "position_c") { | ||||||||
| "continuous" | ||||||||
| } else { | ||||||||
| "discrete" | ||||||||
| } | ||||||||
| warn(glue("Transformation introduced infinite values in {type} {axis}-axis")) | ||||||||
| } | ||||||||
| } | ||||||||
| trans_support_nbreaks <- function(trans) { | ||||||||
| "n" %in% names(formals(trans$breaks)) | ||||||||
| } | ||||||||
| 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 [sec_axis()] is used to specify a secondary axis. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| scale_x_continuous <- function(name = waiver(), breaks = waiver(), | ||||||||
| minor_breaks = waiver(), n.breaks = NULL, | ||||||||
| labels = waiver(), limits = NULL, | ||||||||
| expand = waiver(), oob = censor, | ||||||||
| na.value = NA_real_, trans = "identity", | ||||||||
| guide = waiver(), position = "bottom", | ||||||||
| sec.axis = waiver()) { | ||||||||
| sc <- continuous_scale( | ||||||||
| c("x", "xmin", "xmax", "xend", "xintercept", "xmin_final", "xmax_final", "xlower", "xmiddle", "xupper", "x0"), | ||||||||
| "position_c", identity, name = name, breaks = breaks, n.breaks = n.breaks, | ||||||||
| minor_breaks = minor_breaks, labels = labels, limits = limits, | ||||||||
| expand = expand, oob = oob, na.value = na.value, trans = trans, | ||||||||
| guide = guide, 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(), n.breaks = NULL, | ||||||||
| labels = waiver(), limits = NULL, | ||||||||
| expand = waiver(), oob = censor, | ||||||||
| na.value = NA_real_, trans = "identity", | ||||||||
| guide = waiver(), position = "left", | ||||||||
| sec.axis = waiver()) { | ||||||||
| sc <- continuous_scale( | ||||||||
| c("y", "ymin", "ymax", "yend", "yintercept", "ymin_final", "ymax_final", "lower", "middle", "upper", "y0"), | ||||||||
| "position_c", identity, name = name, breaks = breaks, n.breaks = n.breaks, | ||||||||
| minor_breaks = minor_breaks, labels = labels, limits = limits, | ||||||||
| expand = expand, oob = oob, na.value = na.value, trans = trans, | ||||||||
| guide = guide, 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/scale-type.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| find_scale <- function(aes, x, env = parent.frame()) { | ||||||||
| # Inf is ambiguous; it can be used either with continuous scales or with | ||||||||
| # discrete scales, so just skip in the hope that we will have a better guess | ||||||||
| # with the other layers | ||||||||
| if (is.null(x) || (is_atomic(x) && all(is.infinite(x)))) { | ||||||||
| return(NULL) | ||||||||
| } | ||||||||
| type <- scale_type(x) | ||||||||
| candidates <- paste("scale", aes, type, sep = "_") | ||||||||
| for (scale in candidates) { | ||||||||
| scale_f <- find_global(scale, env, mode = "function") | ||||||||
| if (!is.null(scale_f)) | ||||||||
| return(scale_f()) | ||||||||
| } | ||||||||
| # Failure to find a scale is not an error because some "aesthetics" don't | ||||||||
| # need scales (e.g. group), and it allows others to extend ggplot2 with | ||||||||
| # their own aesthetics | ||||||||
| return(NULL) | ||||||||
| } | ||||||||
| # Look for object first in parent environment and if not found, then in | ||||||||
| # ggplot2 namespace environment. This makes it possible to override default | ||||||||
| # scales by setting them in the parent environment. | ||||||||
| find_global <- function(name, env, mode = "any") { | ||||||||
| if (exists(name, envir = env, mode = mode)) { | ||||||||
| return(get(name, envir = env, mode = mode)) | ||||||||
| } | ||||||||
| nsenv <- asNamespace("ggplot2") | ||||||||
| if (exists(name, envir = nsenv, mode = mode)) { | ||||||||
| return(get(name, envir = nsenv, mode = mode)) | ||||||||
| } | ||||||||
| NULL | ||||||||
| } | ||||||||
| #' Determine default scale type | ||||||||
| #' | ||||||||
| #' You will need to define a method for this method if you want to extend | ||||||||
| #' ggplot2 to handle new types of data. If you simply want to pass the vector | ||||||||
| #' through as an additional aesthetic, return `"identity"`. | ||||||||
| #' | ||||||||
| #' @param x A vector | ||||||||
| #' @return A character vector of scale types. These will be tried in turn | ||||||||
| #' to find a default scale. For example, if `scale_type` returns | ||||||||
| #' `c("foo", "bar")` and the vector is used with the colour aesthetic, | ||||||||
| #' ggplot2 will first look for `scale_colour_foo` then | ||||||||
| #' `scale_colour_bar`. | ||||||||
| #' @export | ||||||||
| #' @keywords internal | ||||||||
| #' @examples | ||||||||
| #' scale_type(1:5) | ||||||||
| #' scale_type("test") | ||||||||
| #' scale_type(Sys.Date()) | ||||||||
| scale_type <- function(x) UseMethod("scale_type") | ||||||||
| #' @export | ||||||||
| scale_type.default <- function(x) { | ||||||||
| message("Don't know how to automatically pick scale for object of type ", | ||||||||
| paste(class(x), collapse = "/"), ". Defaulting to continuous.") | ||||||||
| "continuous" | ||||||||
| } | ||||||||
| #' @export | ||||||||
| scale_type.list <- function(x) "identity" | ||||||||
| #' @export | ||||||||
| scale_type.AsIs <- function(x) "identity" | ||||||||
| #' @export | ||||||||
| scale_type.logical <- function(x) "discrete" | ||||||||
| #' @export | ||||||||
| scale_type.character <- function(x) "discrete" | ||||||||
| #' @export | ||||||||
| scale_type.ordered <- function(x) c("ordinal", "discrete") | ||||||||
| #' @export | ||||||||
| scale_type.factor <- function(x) "discrete" | ||||||||
| #' @export | ||||||||
| scale_type.POSIXt <- function(x) c("datetime", "continuous") | ||||||||
| #' @export | ||||||||
| scale_type.Date <- function(x) c("date", "continuous") | ||||||||
| #' @export | ||||||||
| scale_type.numeric <- function(x) "continuous" | ||||||||
| #' @export | ||||||||
| scale_type.hms <- function(x) "time" | ||||||||
| ggplot2/R/scales-.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| # Scales object encapsulates multiple scales. | ||||||||
| # All input and output done with data.frames to facilitate | ||||||||
| # multiple input and output variables | ||||||||
| scales_list <- function() { | ||||||||
| ggproto(NULL, ScalesList) | ||||||||
| } | ||||||||
| ScalesList <- ggproto("ScalesList", NULL, | ||||||||
| scales = NULL, | ||||||||
| find = function(self, aesthetic) { | ||||||||
| vapply(self$scales, function(x) any(aesthetic %in% x$aesthetics), logical(1)) | ||||||||
| }, | ||||||||
| has_scale = function(self, aesthetic) { | ||||||||
| any(self$find(aesthetic)) | ||||||||
| }, | ||||||||
| add = function(self, scale) { | ||||||||
| if (is.null(scale)) { | ||||||||
| return() | ||||||||
| } | ||||||||
| prev_aes <- self$find(scale$aesthetics) | ||||||||
| if (any(prev_aes)) { | ||||||||
| # Get only the first aesthetic name in the returned vector -- it can | ||||||||
| # sometimes be c("x", "xmin", "xmax", ....) | ||||||||
| scalename <- self$scales[prev_aes][[1]]$aesthetics[1] | ||||||||
| message_wrap("Scale for '", scalename, | ||||||||
| "' is already present. Adding another scale for '", scalename, | ||||||||
| "', which will replace the existing scale.") | ||||||||
| } | ||||||||
| # Remove old scale for this aesthetic (if it exists) | ||||||||
| self$scales <- c(self$scales[!prev_aes], list(scale)) | ||||||||
| }, | ||||||||
| n = function(self) { | ||||||||
| length(self$scales) | ||||||||
| }, | ||||||||
| input = function(self) { | ||||||||
| unlist(lapply(self$scales, "[[", "aesthetics")) | ||||||||
| }, | ||||||||
| # This actually makes a descendant of self, which is functionally the same | ||||||||
| # as a actually clone for most purposes. | ||||||||
| clone = function(self) { | ||||||||
| ggproto(NULL, self, scales = lapply(self$scales, function(s) s$clone())) | ||||||||
| }, | ||||||||
| non_position_scales = function(self) { | ||||||||
| ggproto(NULL, self, scales = self$scales[!self$find("x") & !self$find("y")]) | ||||||||
| }, | ||||||||
| get_scales = function(self, output) { | ||||||||
| scale <- self$scales[self$find(output)] | ||||||||
| if (length(scale) == 0) return() | ||||||||
| scale[[1]] | ||||||||
| } | ||||||||
| ) | ||||||||
| # Train scale from a data frame | ||||||||
| scales_train_df <- function(scales, df, drop = FALSE) { | ||||||||
| if (empty(df) || length(scales$scales) == 0) return() | ||||||||
| lapply(scales$scales, function(scale) scale$train_df(df = df)) | ||||||||
| } | ||||||||
| # Map values from a data.frame. Returns data.frame | ||||||||
| scales_map_df <- function(scales, df) { | ||||||||
| if (empty(df) || length(scales$scales) == 0) return(df) | ||||||||
| mapped <- unlist(lapply(scales$scales, function(scale) scale$map_df(df = df)), recursive = FALSE) | ||||||||
| new_data_frame(c(mapped, df[setdiff(names(df), names(mapped))])) | ||||||||
| } | ||||||||
| # Transform values to cardinal representation | ||||||||
| scales_transform_df <- function(scales, df) { | ||||||||
| if (empty(df) || length(scales$scales) == 0) return(df) | ||||||||
| transformed <- unlist(lapply(scales$scales, function(s) s$transform_df(df = df)), | ||||||||
| recursive = FALSE) | ||||||||
| new_data_frame(c(transformed, df[setdiff(names(df), names(transformed))])) | ||||||||
| } | ||||||||
| # @param aesthetics A list of aesthetic-variable mappings. The name of each | ||||||||
| # item is the aesthetic, and the value of each item is the variable in data. | ||||||||
| scales_add_defaults <- function(scales, data, aesthetics, env) { | ||||||||
| if (is.null(aesthetics)) return() | ||||||||
| names(aesthetics) <- unlist(lapply(names(aesthetics), aes_to_scale)) | ||||||||
| new_aesthetics <- setdiff(names(aesthetics), scales$input()) | ||||||||
| # No new aesthetics, so no new scales to add | ||||||||
| if (is.null(new_aesthetics)) return() | ||||||||
| datacols <- lapply(aesthetics[new_aesthetics], eval_tidy, data = data) | ||||||||
| datacols <- compact(datacols) | ||||||||
| for (aes in names(datacols)) { | ||||||||
| scales$add(find_scale(aes, datacols[[aes]], env)) | ||||||||
| } | ||||||||
| } | ||||||||
| # Add missing but required scales. | ||||||||
| # @param aesthetics A character vector of aesthetics. Typically c("x", "y"). | ||||||||
| scales_add_missing <- function(plot, aesthetics, env) { | ||||||||
| # Keep only aesthetics that aren't already in plot$scales | ||||||||
| aesthetics <- setdiff(aesthetics, plot$scales$input()) | ||||||||
| for (aes in aesthetics) { | ||||||||
| scale_name <- paste("scale", aes, "continuous", sep = "_") | ||||||||
| scale_f <- find_global(scale_name, env, mode = "function") | ||||||||
| plot$scales$add(scale_f()) | ||||||||
| } | ||||||||
| } | ||||||||
| 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 | ||||||||
| #' @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. A `function` can be created | ||||||||
| #' from a `formula` (e.g. `~ head(.x, 10)`). | ||||||||
| #' @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`. | ||||||||
| #' @param key_glyph A legend key drawing function or a string providing the | ||||||||
| #' function name minus the `draw_key_` prefix. See [draw_key] for details. | ||||||||
| #' @param layer_class The type of layer object to be constructued. This is | ||||||||
| #' intended for ggplot2 internal use only. | ||||||||
| #' @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, key_glyph = NULL, layer_class = Layer) { | ||||||||
| if (is.null(geom)) | ||||||||
| abort("Attempted to create layer with no geom.") | ||||||||
| if (is.null(stat)) | ||||||||
| abort("Attempted to create layer with no stat.") | ||||||||
| if (is.null(position)) | ||||||||
| abort("Attempted to create layer with no position.") | ||||||||
| # Handle show_guide/show.legend | ||||||||
| if (!is.null(params$show_guide)) { | ||||||||
| warn("`show_guide` has been deprecated. Please use `show.legend` instead.") | ||||||||
| show.legend <- params$show_guide | ||||||||
| params$show_guide <- NULL | ||||||||
| } | ||||||||
| # 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 | ||||||||
| } | ||||||||
| # Special case for key_glyph parameter which is handed in through | ||||||||
| # params since all geoms/stats forward ... to params | ||||||||
| if (!is.null(params$key_glyph)) { | ||||||||
| key_glyph <- params$key_glyph | ||||||||
| params$key_glyph <- NULL # remove to avoid warning about unknown parameter | ||||||||
| } | ||||||||
| # 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) { | ||||||||
| warn(glue("Ignoring unknown parameters: ", paste(extra_param, collapse = ", "))) | ||||||||
| } | ||||||||
| extra_aes <- setdiff( | ||||||||
| mapped_aesthetics(mapping), | ||||||||
| c(geom$aesthetics(), stat$aesthetics()) | ||||||||
| ) | ||||||||
| if (check.aes && length(extra_aes) > 0) { | ||||||||
| warn(glue("Ignoring unknown aesthetics: ", paste(extra_aes, collapse = ", "))) | ||||||||
| } | ||||||||
| # adjust the legend draw key if requested | ||||||||
| geom <- set_draw_key(geom, key_glyph) | ||||||||
| ggproto("LayerInstance", layer_class, | ||||||||
| 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 +?" | ||||||||
| ) | ||||||||
| } | ||||||||
| abort(msg) | ||||||||
| } | ||||||||
| # 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)) { | ||||||||
| abort("Data function must return a data.frame") | ||||||||
| } | ||||||||
| data | ||||||||
| } else { | ||||||||
| self$data | ||||||||
| } | ||||||||
| }, | ||||||||
| # hook to allow a layer access to the final layer data | ||||||||
| # in input form and to global plot info | ||||||||
| setup_layer = function(self, data, plot) { | ||||||||
| 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) | ||||||||
| modifiers <- is_scaled_aes(aesthetics) | ||||||||
| aesthetics <- aesthetics[!set & !calculated & !modifiers] | ||||||||
| # 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 aesthetics | ||||||||
| env <- child_env(baseenv(), stage = stage) | ||||||||
| evaled <- lapply(aesthetics, eval_tidy, data = data, env = env) | ||||||||
| evaled <- compact(evaled) | ||||||||
| # Check for discouraged usage in mapping | ||||||||
| warn_for_aes_extract_usage(aesthetics, data[setdiff(names(data), "PANEL")]) | ||||||||
| # Check aesthetic values | ||||||||
| nondata_cols <- check_nondata_cols(evaled) | ||||||||
| if (length(nondata_cols) > 0) { | ||||||||
| msg <- paste0( | ||||||||
| "Aesthetics must be valid data columns. Problematic aesthetic(s): ", | ||||||||
| paste0(vapply(nondata_cols, function(x) {paste0(x, " = ", as_label(aesthetics[[x]]))}, character(1)), collapse = ", "), | ||||||||
| ". \nDid you mistype the name of a data column or forget to add after_stat()?" | ||||||||
| ) | ||||||||
| abort(msg) | ||||||||
| } | ||||||||
| 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()) | ||||||||
| # Make sure data columns are converted to correct names. If not done, a | ||||||||
| # column with e.g. a color name will not be found in an after_stat() | ||||||||
| # evaluation (since the evaluation symbols gets renamed) | ||||||||
| data <- rename_aes(data) | ||||||||
| # 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) | is_staged_aes(aesthetics)]) | ||||||||
| if (length(new) == 0) return(data) | ||||||||
| # Add map stat output to aesthetics | ||||||||
| env <- child_env(baseenv(), stat = stat, after_stat = after_stat) | ||||||||
| stage_mask <- child_env(emptyenv(), stage = stage_calculated) | ||||||||
| mask <- new_data_mask(as_environment(data, stage_mask), stage_mask) | ||||||||
| mask$.data <- as_data_pronoun(mask) | ||||||||
| new <- substitute_aes(new) | ||||||||
| stat_data <- lapply(new, eval_tidy, mask, env) | ||||||||
| # Check that all columns in aesthetic stats are valid data | ||||||||
| nondata_stat_cols <- check_nondata_cols(stat_data) | ||||||||
| if (length(nondata_stat_cols) > 0) { | ||||||||
| msg <- paste0( | ||||||||
| "Aesthetics must be valid computed stats. Problematic aesthetic(s): ", | ||||||||
| paste0(vapply(nondata_stat_cols, function(x) {paste0(x, " = ", as_label(aesthetics[[x]]))}, character(1)), collapse = ", "), | ||||||||
| ". \nDid you map your stat in the wrong layer?" | ||||||||
| ) | ||||||||
| abort(msg) | ||||||||
| } | ||||||||
| names(stat_data) <- names(new) | ||||||||
| stat_data <- new_data_frame(compact(stat_data)) | ||||||||
| # 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_params <- self$geom$setup_params(data, c(self$geom_params, self$aes_params)) | ||||||||
| self$geom$setup_data(data, self$geom_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) | ||||||||
| aesthetics <- self$mapping | ||||||||
| modifiers <- aesthetics[is_scaled_aes(aesthetics) | is_staged_aes(aesthetics)] | ||||||||
| self$geom$use_defaults(data, self$aes_params, modifiers) | ||||||||
| }, | ||||||||
| 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 = to_lower_ascii(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)) { | ||||||||
| abort(glue("Can't find `{argname}` called '{x}'")) | ||||||||
| } else { | ||||||||
| obj | ||||||||
| } | ||||||||
| } else { | ||||||||
| abort(glue( | ||||||||
| "`{argname}` must be either a string or a {subclass} object, not {obj_desc(x)}" | ||||||||
| )) | ||||||||
| } | ||||||||
| } | ||||||||
| 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)) | ||||||||
| ) | ||||||||
| } | ||||||||
| } | ||||||||
| # helper function to adjust the draw_key slot of a geom | ||||||||
| # if a custom key glyph is requested | ||||||||
| set_draw_key <- function(geom, draw_key = NULL) { | ||||||||
| if (is.null(draw_key)) { | ||||||||
| return(geom) | ||||||||
| } | ||||||||
| if (is.character(draw_key)) { | ||||||||
| draw_key <- paste0("draw_key_", draw_key) | ||||||||
| } | ||||||||
| draw_key <- match.fun(draw_key) | ||||||||
| ggproto("", geom, draw_key = draw_key) | ||||||||
| } | ||||||||
| labeling/R/labeling.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Functions for positioning tick labels on axes | ||||||||
| #' | ||||||||
| #' \tabular{ll}{ | ||||||||
| #' Package: \tab labeling\cr | ||||||||
| #' Type: \tab Package\cr | ||||||||
| #' Version: \tab 0.2\cr | ||||||||
| #' Date: \tab 2011-04-01\cr | ||||||||
| #' License: \tab Unlimited\cr | ||||||||
| #' LazyLoad: \tab yes\cr | ||||||||
| #' } | ||||||||
| #' | ||||||||
| #' Implements a number of axis labeling schemes, including those | ||||||||
| #' compared in An Extension of Wilkinson's Algorithm for Positioning Tick Labels on Axes | ||||||||
| #' by Talbot, Lin, and Hanrahan, InfoVis 2010. | ||||||||
| #' | ||||||||
| #' @name labeling-package | ||||||||
| #' @aliases labeling | ||||||||
| #' @docType package | ||||||||
| #' @title Axis labeling | ||||||||
| #' @author Justin Talbot \email{jtalbot@@stanford.edu} | ||||||||
| #' @references | ||||||||
| #' Heckbert, P. S. (1990) Nice numbers for graph labels, Graphics Gems I, Academic Press Professional, Inc. | ||||||||
| #' Wilkinson, L. (2005) The Grammar of Graphics, Springer-Verlag New York, Inc. | ||||||||
| #' Talbot, J., Lin, S., Hanrahan, P. (2010) An Extension of Wilkinson's Algorithm for Positioning Tick Labels on Axes, InfoVis 2010. | ||||||||
| #' @keywords dplot | ||||||||
| #' @seealso \code{\link{extended}}, \code{\link{wilkinson}}, \code{\link{heckbert}}, \code{\link{rpretty}}, \code{\link{gnuplot}}, \code{\link{matplotlib}}, \code{\link{nelder}}, \code{\link{sparks}}, \code{\link{thayer}}, \code{\link{pretty}} | ||||||||
| #' @examples | ||||||||
| #' heckbert(8.1, 14.1, 4) # 5 10 15 | ||||||||
| #' wilkinson(8.1, 14.1, 4) # 8 9 10 11 12 13 14 15 | ||||||||
| #' extended(8.1, 14.1, 4) # 8 10 12 14 | ||||||||
| #' # When plotting, extend the plot range to include the labeling | ||||||||
| #' # Should probably have a helper function to make this easier | ||||||||
| #' data(iris) | ||||||||
| #' x <- iris$Sepal.Width | ||||||||
| #' y <- iris$Sepal.Length | ||||||||
| #' xl <- extended(min(x), max(x), 6) | ||||||||
| #' yl <- extended(min(y), max(y), 6) | ||||||||
| #' plot(x, y, | ||||||||
| #' xlim=c(min(x,xl),max(x,xl)), | ||||||||
| #' ylim=c(min(y,yl),max(y,yl)), | ||||||||
| #' axes=FALSE, main="Extended labeling") | ||||||||
| #' axis(1, at=xl) | ||||||||
| #' axis(2, at=yl) | ||||||||
| c() | ||||||||
| #' Heckbert's labeling algorithm | ||||||||
| #' | ||||||||
| #' @param dmin minimum of the data range | ||||||||
| #' @param dmax maximum of the data range | ||||||||
| #' @param m number of axis labels | ||||||||
| #' @return vector of axis label locations | ||||||||
| #' @references | ||||||||
| #' Heckbert, P. S. (1990) Nice numbers for graph labels, Graphics Gems I, Academic Press Professional, Inc. | ||||||||
| #' @author Justin Talbot \email{jtalbot@@stanford.edu} | ||||||||
| #' @export | ||||||||
| heckbert <- function(dmin, dmax, m) | ||||||||
| { | ||||||||
| range <- .heckbert.nicenum((dmax-dmin), FALSE) | ||||||||
| lstep <- .heckbert.nicenum(range/(m-1), TRUE) | ||||||||
| lmin <- floor(dmin/lstep)*lstep | ||||||||
| lmax <- ceiling(dmax/lstep)*lstep | ||||||||
| seq(lmin, lmax, by=lstep) | ||||||||
| } | ||||||||
| .heckbert.nicenum <- function(x, round) | ||||||||
| { | ||||||||
| e <- floor(log10(x)) | ||||||||
| f <- x / (10^e) | ||||||||
| if(round) | ||||||||
| { | ||||||||
| if(f < 1.5) nf <- 1 | ||||||||
| else if(f < 3) nf <- 2 | ||||||||
| else if(f < 7) nf <- 5 | ||||||||
| else nf <- 10 | ||||||||
| } | ||||||||
| else | ||||||||
| { | ||||||||
| if(f <= 1) nf <- 1 | ||||||||
| else if(f <= 2) nf <- 2 | ||||||||
| else if(f <= 5) nf <- 5 | ||||||||
| else nf <- 10 | ||||||||
| } | ||||||||
| nf * (10^e) | ||||||||
| } | ||||||||
| #' Wilkinson's labeling algorithm | ||||||||
| #' | ||||||||
| #' @param dmin minimum of the data range | ||||||||
| #' @param dmax maximum of the data range | ||||||||
| #' @param m number of axis labels | ||||||||
| #' @param Q set of nice numbers | ||||||||
| #' @param mincoverage minimum ratio between the the data range and the labeling range, controlling the whitespace around the labeling (default = 0.8) | ||||||||
| #' @param mrange range of \code{m}, the number of tick marks, that should be considered in the optimization search | ||||||||
| #' @return vector of axis label locations | ||||||||
| #' @note Ported from Wilkinson's Java implementation with some changes. | ||||||||
| #' Changes: 1) m (the target number of ticks) is hard coded in Wilkinson's implementation as 5. | ||||||||
| #' Here we allow it to vary as a parameter. Since m is fixed, | ||||||||
| #' Wilkinson only searches over a fixed range 4-13 of possible resulting ticks. | ||||||||
| #' We broadened the search range to max(floor(m/2),2) to ceiling(6*m), | ||||||||
| #' which is a larger range than Wilkinson considers for 5 and allows us to vary m, | ||||||||
| #' including using non-integer values of m. | ||||||||
| #' 2) Wilkinson's implementation assumes that the scores are non-negative. But, his revised | ||||||||
| #' granularity function can be extremely negative. We tweaked the code to allow negative scores. | ||||||||
| #' We found that this produced better labelings. | ||||||||
| #' 3) We added 10 to Q. This seemed to be necessary to get steps of size 1. | ||||||||
| #' It is possible for this algorithm to find no solution. | ||||||||
| #' In Wilkinson's implementation, instead of failing, he returns the non-nice labels spaced evenly from min to max. | ||||||||
| #' We want to detect this case, so we return NULL. If this happens, the search range, mrange, needs to be increased. | ||||||||
| #' @references | ||||||||
| #' Wilkinson, L. (2005) The Grammar of Graphics, Springer-Verlag New York, Inc. | ||||||||
| #' @author Justin Talbot \email{jtalbot@@stanford.edu} | ||||||||
| #' @export | ||||||||
| wilkinson <-function(dmin, dmax, m, Q = c(1,5,2,2.5,3,4,1.5,7,6,8,9), mincoverage = 0.8, mrange=max(floor(m/2),2):ceiling(6*m)) | ||||||||
| { | ||||||||
| best <- NULL | ||||||||
| for(k in mrange) | ||||||||
| { | ||||||||
| result <- .wilkinson.nice.scale(dmin, dmax, k, Q, mincoverage, mrange, m) | ||||||||
| if(!is.null(result) && (is.null(best) || result$score > best$score)) | ||||||||
| { | ||||||||
| best <- result | ||||||||
| } | ||||||||
| } | ||||||||
| seq(best$lmin, best$lmax, by=best$lstep) | ||||||||
| } | ||||||||
| .wilkinson.nice.scale <- function(min, max, k, Q = c(1,5,2,2.5,3,4,1.5,7,6,8,9), mincoverage = 0.8, mrange=c(), m=k) | ||||||||
| { | ||||||||
| Q <- c(10, Q) | ||||||||
| range <- max-min | ||||||||
| intervals <- k-1 | ||||||||
| granularity <- 1 - abs(k-m)/m | ||||||||
| delta <- range / intervals | ||||||||
| base <- floor(log10(delta)) | ||||||||
| dbase <- 10^base | ||||||||
| best <- NULL | ||||||||
| for(i in 1:length(Q)) | ||||||||
| { | ||||||||
| tdelta <- Q[i] * dbase | ||||||||
| tmin <- floor(min/tdelta) * tdelta | ||||||||
| tmax <- tmin + intervals * tdelta | ||||||||
| if(tmin <= min && tmax >= max) | ||||||||
| { | ||||||||
| roundness <- 1 - ((i-1) - ifelse(tmin <= 0 && tmax >= 0, 1, 0)) / length(Q) | ||||||||
| coverage <- (max-min)/(tmax-tmin) | ||||||||
| if(coverage > mincoverage) | ||||||||
| { | ||||||||
| tnice <- granularity + roundness + coverage | ||||||||
| ## Wilkinson's implementation contains code to favor certain ranges of labels | ||||||||
| ## e.g. those balanced around or anchored at 0, etc. | ||||||||
| ## We did not evaluate this type of optimization in the paper, so did not include it. | ||||||||
| ## Obviously this optimization component could also be added to our function. | ||||||||
| #if(tmin == -tmax || tmin == 0 || tmax == 1 || tmax == 100) | ||||||||
| # tnice <- tnice + 1 | ||||||||
| #if(tmin == 0 && tmax == 1 || tmin == 0 && tmax == 100) | ||||||||
| # tnice <- tnice + 1 | ||||||||
| if(is.null(best) || tnice > best$score) | ||||||||
| { | ||||||||
| best <- list(lmin=tmin, | ||||||||
| lmax=tmax, | ||||||||
| lstep=tdelta, | ||||||||
| score=tnice | ||||||||
| ) | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| best | ||||||||
| } | ||||||||
| ## The Extended-Wilkinson algorithm described in the paper. | ||||||||
| ## Our scoring functions, including the approximations for limiting the search | ||||||||
| .simplicity <- function(q, Q, j, lmin, lmax, lstep) | ||||||||
| { | ||||||||
| eps <- .Machine$double.eps * 100 | ||||||||
| n <- length(Q) | ||||||||
| i <- match(q, Q)[1] | ||||||||
| v <- ifelse( (lmin %% lstep < eps || lstep - (lmin %% lstep) < eps) && lmin <= 0 && lmax >=0, 1, 0) | ||||||||
| 1 - (i-1)/(n-1) - j + v | ||||||||
| } | ||||||||
| .simplicity.max <- function(q, Q, j) | ||||||||
| { | ||||||||
| n <- length(Q) | ||||||||
| i <- match(q, Q)[1] | ||||||||
| v <- 1 | ||||||||
| 1 - (i-1)/(n-1) - j + v | ||||||||
| } | ||||||||
| .coverage <- function(dmin, dmax, lmin, lmax) | ||||||||
| { | ||||||||
| range <- dmax-dmin | ||||||||
| 1 - 0.5 * ((dmax-lmax)^2+(dmin-lmin)^2) / ((0.1*range)^2) | ||||||||
| } | ||||||||
| .coverage.max <- function(dmin, dmax, span) | ||||||||
| { | ||||||||
| range <- dmax-dmin | ||||||||
| if(span > range) | ||||||||
| { | ||||||||
| half <- (span-range)/2 | ||||||||
| 1 - 0.5 * (half^2 + half^2) / ((0.1 * range)^2) | ||||||||
| } | ||||||||
| else | ||||||||
| { | ||||||||
| 1 | ||||||||
| } | ||||||||
| } | ||||||||
| .density <- function(k, m, dmin, dmax, lmin, lmax) | ||||||||
| { | ||||||||
| r <- (k-1) / (lmax-lmin) | ||||||||
| rt <- (m-1) / (max(lmax,dmax)-min(dmin,lmin)) | ||||||||
| 2 - max( r/rt, rt/r ) | ||||||||
| } | ||||||||
| .density.max <- function(k, m) | ||||||||
| { | ||||||||
| if(k >= m) | ||||||||
| 2 - (k-1)/(m-1) | ||||||||
| else | ||||||||
| 1 | ||||||||
| } | ||||||||
| .legibility <- function(lmin, lmax, lstep) | ||||||||
| { | ||||||||
| 1 ## did all the legibility tests in C#, not in R. | ||||||||
| } | ||||||||
| #' An Extension of Wilkinson's Algorithm for Position Tick Labels on Axes | ||||||||
| #' | ||||||||
| #' \code{extended} is an enhanced version of Wilkinson's optimization-based axis labeling approach. It is described in detail in our paper. See the references. | ||||||||
| #' | ||||||||
| #' @param dmin minimum of the data range | ||||||||
| #' @param dmax maximum of the data range | ||||||||
| #' @param m number of axis labels | ||||||||
| #' @param Q set of nice numbers | ||||||||
| #' @param only.loose if true, the extreme labels will be outside the data range | ||||||||
| #' @param w weights applied to the four optimization components (simplicity, coverage, density, and legibility) | ||||||||
| #' @return vector of axis label locations | ||||||||
| #' @references | ||||||||
| #' Talbot, J., Lin, S., Hanrahan, P. (2010) An Extension of Wilkinson's Algorithm for Positioning Tick Labels on Axes, InfoVis 2010. | ||||||||
| #' @author Justin Talbot \email{jtalbot@@stanford.edu} | ||||||||
| #' @export | ||||||||
| extended <- function(dmin, dmax, m, Q=c(1,5,2,2.5,4,3), only.loose=FALSE, w=c(0.25,0.2,0.5,0.05)) | ||||||||
| { | ||||||||
| eps <- .Machine$double.eps * 100 | ||||||||
| if(dmin > dmax) { | ||||||||
| temp <- dmin | ||||||||
| dmin <- dmax | ||||||||
| dmax <- temp | ||||||||
| } | ||||||||
| if(dmax - dmin < eps) { | ||||||||
| #if the range is near the floating point limit, | ||||||||
| #let seq generate some equally spaced steps. | ||||||||
| return(seq(from=dmin, to=dmax, length.out=m)) | ||||||||
| } | ||||||||
| if((dmax - dmin) > sqrt(.Machine$double.xmax)) { | ||||||||
| #if the range is too large | ||||||||
| #let seq generate some equally spaced steps. | ||||||||
| return(seq(from=dmin, to=dmax, length.out=m)) | ||||||||
| } | ||||||||
| n <- length(Q) | ||||||||
| best <- list() | ||||||||
| best$score <- -2 | ||||||||
| j <- 1 | ||||||||
| while(j < Inf) | ||||||||
| { | ||||||||
| for(q in Q) | ||||||||
| { | ||||||||
| sm <- .simplicity.max(q, Q, j) | ||||||||
| if((w[1]*sm+w[2]+w[3]+w[4]) < best$score) | ||||||||
| { | ||||||||
| j <- Inf | ||||||||
| break | ||||||||
| } | ||||||||
| k <- 2 | ||||||||
| while(k < Inf) # loop over tick counts | ||||||||
| { | ||||||||
| dm <- .density.max(k, m) | ||||||||
| if((w[1]*sm+w[2]+w[3]*dm+w[4]) < best$score) | ||||||||
| break | ||||||||
| delta <- (dmax-dmin)/(k+1)/j/q | ||||||||
| z <- ceiling(log(delta, base=10)) | ||||||||
| while(z < Inf) | ||||||||
| { | ||||||||
| step <- j*q*10^z | ||||||||
| cm <- .coverage.max(dmin, dmax, step*(k-1)) | ||||||||
| if((w[1]*sm+w[2]*cm+w[3]*dm+w[4]) < best$score) | ||||||||
| break | ||||||||
| min_start <- floor(dmax/(step))*j - (k - 1)*j | ||||||||
| max_start <- ceiling(dmin/(step))*j | ||||||||
| if(min_start > max_start) | ||||||||
| { | ||||||||
| z <- z+1 | ||||||||
| next | ||||||||
| } | ||||||||
| for(start in min_start:max_start) | ||||||||
| { | ||||||||
| lmin <- start * (step/j) | ||||||||
| lmax <- lmin + step*(k-1) | ||||||||
| lstep <- step | ||||||||
| s <- .simplicity(q, Q, j, lmin, lmax, lstep) | ||||||||
| c <- .coverage(dmin, dmax, lmin, lmax) | ||||||||
| g <- .density(k, m, dmin, dmax, lmin, lmax) | ||||||||
| l <- .legibility(lmin, lmax, lstep) | ||||||||
| score <- w[1]*s + w[2]*c + w[3]*g + w[4]*l | ||||||||
| if(score > best$score && (!only.loose || (lmin <= dmin && lmax >= dmax))) | ||||||||
| { | ||||||||
| best <- list(lmin=lmin, | ||||||||
| lmax=lmax, | ||||||||
| lstep=lstep, | ||||||||
| score=score) | ||||||||
| } | ||||||||
| } | ||||||||
| z <- z+1 | ||||||||
| } | ||||||||
| k <- k+1 | ||||||||
| } | ||||||||
| } | ||||||||
| j <- j + 1 | ||||||||
| } | ||||||||
| seq(from=best$lmin, to=best$lmax, by=best$lstep) | ||||||||
| } | ||||||||
| ## Quantitative evaluation plots (Figures 2 and 3 in the paper) | ||||||||
| #' Generate figures from An Extension of Wilkinson's Algorithm for Position Tick Labels on Axes | ||||||||
| #' | ||||||||
| #' Generates Figures 2 and 3 from our paper. | ||||||||
| #' | ||||||||
| #' @param samples number of samples to use (in the paper we used 10000, but that takes awhile to run). | ||||||||
| #' @return produces plots as a side effect | ||||||||
| #' @references | ||||||||
| #' Talbot, J., Lin, S., Hanrahan, P. (2010) An Extension of Wilkinson's Algorithm for Positioning Tick Labels on Axes, InfoVis 2010. | ||||||||
| #' @author Justin Talbot \email{jtalbot@@stanford.edu} | ||||||||
| #' @export | ||||||||
| extended.figures <- function(samples = 100) | ||||||||
| { | ||||||||
| oldpar <- par() | ||||||||
| par(ask=TRUE) | ||||||||
| a <- runif(samples, -100, 400) | ||||||||
| b <- runif(samples, -100, 400) | ||||||||
| low <- pmin(a,b) | ||||||||
| high <- pmax(a,b) | ||||||||
| ticks <- runif(samples, 2, 10) | ||||||||
| generate.labelings <- function(labeler, dmin, dmax, ticks, ...) | ||||||||
| { | ||||||||
| mapply(labeler, dmin, dmax, ticks, SIMPLIFY=FALSE, MoreArgs=list(...)) | ||||||||
| } | ||||||||
| h1 <- generate.labelings(heckbert, low, high, ticks) | ||||||||
| w1 <- generate.labelings(wilkinson, low, high, ticks, mincoverage=0.8) | ||||||||
| f1 <- generate.labelings(extended, low, high, ticks, only.loose=TRUE) | ||||||||
| e1 <- generate.labelings(extended, low, high, ticks) | ||||||||
| figure2 <- function(r, names) | ||||||||
| { | ||||||||
| for(i in 1:length(r)) | ||||||||
| { | ||||||||
| d <- r[[i]] | ||||||||
| #plot coverage | ||||||||
| cover <- sapply(d, function(x) {max(x)-min(x)})/(high-low) | ||||||||
| hist(cover, breaks=seq(from=-0.01,to=1000,by=0.02), xlab="", ylab=names[i], main=ifelse(i==1, "Density", ""), col="darkgray", lab=c(3,3,3), xlim=c(0.5,3.5), ylim=c(0,0.12*samples), axes=FALSE, border=FALSE) | ||||||||
| #hist(cover) | ||||||||
| axis(side=1, at=c(0,1,2,3,4), xlab="hello", line=-0.1, lwd=0.5) | ||||||||
| # plot density | ||||||||
| dens <- sapply(d, length) / ticks | ||||||||
| hist(dens, breaks=seq(from=-0.01,to=10,by=0.02), xlab="", ylab=names[i], main=ifelse(i==1, "Density", ""), col="darkgray", lab=c(3,3,3), xlim=c(0.5,3.5), ylim=c(0,0.06*samples), axes=FALSE, border=FALSE) | ||||||||
| axis(side=1, at=c(0,1,2,3,4), xlab="hello", line=-0.1, lwd=0.5) | ||||||||
| } | ||||||||
| } | ||||||||
| par(mfrow=c(4, 2), mar=c(0.5,1.85,1,0), oma=c(1,0,1,0), mgp=c(0,0.5,-0.3), font.main=1, font.lab=1, cex.lab=1, cex.main=1, tcl=-0.2) | ||||||||
| figure2(list(h1,w1, f1, e1), names=c("Heckbert", "Wilkinson", "Extended\n(loose)", "Extended\n(flexible)")) | ||||||||
| figure3 <- function(r, names) | ||||||||
| { | ||||||||
| for(i in 1:length(r)) | ||||||||
| { | ||||||||
| d <- r[[i]] | ||||||||
| steps <- sapply(d, function(x) round(median(diff(x)), 2)) | ||||||||
| steps <- steps / (10^floor(log10(steps))) | ||||||||
| tab <- table(steps) | ||||||||
| barplot(rev(tab), xlim=c(0,0.4*samples), horiz=TRUE, xlab=ifelse(i==1,"Frequency",""), xaxt='n', yaxt='s', las=1, main=names[i], border=NA, col="gray") | ||||||||
| } | ||||||||
| } | ||||||||
| par(mfrow=c(1,4), mar=c(0.5, 0.75, 2, 0.5), oma=c(0,2,1,1), mgp=c(0,0.75,-0.3), cex.lab=1, cex.main=1) | ||||||||
| figure3(list(h1,w1, f1, e1), names=c("Heckbert", "Wilkinson", "Extended\n(loose)", "Extended\n(flexible)")) | ||||||||
| par(oldpar) | ||||||||
| } | ||||||||
| #' Nelder's labeling algorithm | ||||||||
| #' | ||||||||
| #' @param dmin minimum of the data range | ||||||||
| #' @param dmax maximum of the data range | ||||||||
| #' @param m number of axis labels | ||||||||
| #' @param Q set of nice numbers | ||||||||
| #' @return vector of axis label locations | ||||||||
| #' @references | ||||||||
| #' Nelder, J. A. (1976) AS 96. A Simple Algorithm for Scaling Graphs, Journal of the Royal Statistical Society. Series C., pp. 94-96. | ||||||||
| #' @author Justin Talbot \email{jtalbot@@stanford.edu} | ||||||||
| #' @export | ||||||||
| nelder <- function(dmin, dmax, m, Q = c(1,1.2,1.6,2,2.5,3,4,5,6,8,10)) | ||||||||
| { | ||||||||
| ntick <- floor(m) | ||||||||
| tol <- 5e-6 | ||||||||
| bias <- 1e-4 | ||||||||
| intervals <- m-1 | ||||||||
| x <- abs(dmax) | ||||||||
| if(x == 0) x <- 1 | ||||||||
| if(!((dmax-dmin)/x > tol)) | ||||||||
| { | ||||||||
| ## special case handling for very small ranges. Not implemented yet. | ||||||||
| } | ||||||||
| step <- (dmax-dmin)/intervals | ||||||||
| s <- step | ||||||||
| while(s <= 1) | ||||||||
| s <- s*10 | ||||||||
| while(s > 10) | ||||||||
| s <- s/10 | ||||||||
| x <- s-bias | ||||||||
| unit <- 1 | ||||||||
| for(i in 1:length(Q)) | ||||||||
| { | ||||||||
| if(x < Q[i]) | ||||||||
| { | ||||||||
| unit <- i | ||||||||
| break | ||||||||
| } | ||||||||
| } | ||||||||
| step <- step * Q[unit] / s | ||||||||
| range <- step*intervals | ||||||||
| x <- 0.5 * (1+ (dmin+dmax-range) / step) | ||||||||
| j <- floor(x-bias) | ||||||||
| valmin <- step * j | ||||||||
| if(dmin > 0 && range >= dmax) | ||||||||
| valmin <- 0 | ||||||||
| valmax <- valmin + range | ||||||||
| if(!(dmax > 0 || range < -dmin)) | ||||||||
| { | ||||||||
| valmax <- 0 | ||||||||
| valmin <- -range | ||||||||
| } | ||||||||
| seq(from=valmin, to=valmax, by=step) | ||||||||
| } | ||||||||
| #' R's pretty algorithm implemented in R | ||||||||
| #' | ||||||||
| #' @param dmin minimum of the data range | ||||||||
| #' @param dmax maximum of the data range | ||||||||
| #' @param m number of axis labels | ||||||||
| #' @param n number of axis intervals (specify one of \code{m} or \code{n}) | ||||||||
| #' @param min.n nonnegative integer giving the \emph{minimal} number of intervals. If \code{min.n == 0}, \code{pretty(.)} may return a single value. | ||||||||
| #' @param shrink.sml positive numeric by a which a default scale is shrunk in the case when \code{range(x)} is very small (usually 0). | ||||||||
| #' @param high.u.bias non-negative numeric, typically \code{> 1}. The interval unit is determined as \code{\{1,2,5,10\}} times \code{b}, a power of 10. Larger \code{high.u.bias} values favor larger units. | ||||||||
| #' @param u5.bias non-negative numeric multiplier favoring factor 5 over 2. Default and 'optimal': \code{u5.bias = .5 + 1.5*high.u.bias}. | ||||||||
| #' @return vector of axis label locations | ||||||||
| #' @references | ||||||||
| #' Becker, R. A., Chambers, J. M. and Wilks, A. R. (1988) \emph{The New S Language}. Wadsworth & Brooks/Cole. | ||||||||
| #' @author Justin Talbot \email{jtalbot@@stanford.edu} | ||||||||
| #' @export | ||||||||
| rpretty <- function(dmin, dmax, m=6, n=floor(m)-1, min.n=n%/%3, shrink.sml = 0.75, high.u.bias=1.5, u5.bias=0.5 + 1.5*high.u.bias) | ||||||||
| { | ||||||||
| ndiv <- n | ||||||||
| h <- high.u.bias | ||||||||
| h5 <- u5.bias | ||||||||
| dx <- dmax-dmin | ||||||||
| if(dx==0 && dmax==0) | ||||||||
| { | ||||||||
| cell <- 1 | ||||||||
| i_small <- TRUE | ||||||||
| U <- 1 | ||||||||
| } | ||||||||
| else | ||||||||
| { | ||||||||
| cell <- max(abs(dmin), abs(dmax)) | ||||||||
| U <- 1 + ifelse(h5 >= 1.5*h+0.5, 1/(1+h), 1.5/(1+h5)) | ||||||||
| i_small = dx < (cell * U * max(1, ndiv) * 1e-07 * 3) | ||||||||
| } | ||||||||
| if(i_small) | ||||||||
| { | ||||||||
| if(cell > 10) | ||||||||
| { | ||||||||
| cell <- 9+cell/10 | ||||||||
| } | ||||||||
| cell <- cell * shrink.sml | ||||||||
| if(min.n > 1) cell <- cell/min.n | ||||||||
| } | ||||||||
| else | ||||||||
| { | ||||||||
| cell <- dx | ||||||||
| if(ndiv > 1) cell <- cell/ndiv | ||||||||
| } | ||||||||
| if(cell < 20 * 1e-07) | ||||||||
| cell <- 20 * 1e-07 | ||||||||
| base <- 10^floor(log10(cell)) | ||||||||
| unit <- base | ||||||||
| if((2*base)-cell < h*(cell-unit)) | ||||||||
| { | ||||||||
| unit <- 2*base | ||||||||
| if((5*base)-cell < h5*(cell-unit)) | ||||||||
| { | ||||||||
| unit <- 5*base | ||||||||
| if((10*base)-cell < h*(cell-unit)) | ||||||||
| unit <- 10*base | ||||||||
| } | ||||||||
| } | ||||||||
| # track down lattice labelings... | ||||||||
| ## Maybe used to correct for the epsilon here?? | ||||||||
| ns <- floor(dmin/unit + 1e-07) | ||||||||
| nu <- ceiling(dmax/unit - 1e-07) | ||||||||
| ## Extend the range out beyond the data. Does this ever happen?? | ||||||||
| while(ns*unit > dmin+(1e-07*unit)) ns <- ns-1 | ||||||||
| while(nu*unit < dmax-(1e-07*unit)) nu <- nu+1 | ||||||||
| ## If we don't have quite enough labels, extend the range out to make more (these labels are beyond the data :( ) | ||||||||
| k <- floor(0.5 + nu-ns) | ||||||||
| if(k < min.n) | ||||||||
| { | ||||||||
| k <- min.n - k | ||||||||
| if(ns >=0) | ||||||||
| { | ||||||||
| nu <- nu + k/2 | ||||||||
| ns <- ns - k/2 + k%%2 | ||||||||
| } | ||||||||
| else | ||||||||
| { | ||||||||
| ns <- ns - k/2 | ||||||||
| nu <- nu + k/2 + k%%2 | ||||||||
| } | ||||||||
| ndiv <- min.n | ||||||||
| } | ||||||||
| else | ||||||||
| { | ||||||||
| ndiv <- k | ||||||||
| } | ||||||||
| graphmin <- ns*unit | ||||||||
| graphmax <- nu*unit | ||||||||
| seq(from=graphmin, to=graphmax, by=unit) | ||||||||
| } | ||||||||
| #' Matplotlib's labeling algorithm | ||||||||
| #' | ||||||||
| #' @param dmin minimum of the data range | ||||||||
| #' @param dmax maximum of the data range | ||||||||
| #' @param m number of axis labels | ||||||||
| #' @return vector of axis label locations | ||||||||
| #' @references | ||||||||
| #' \url{http://matplotlib.sourceforge.net/} | ||||||||
| #' @author Justin Talbot \email{jtalbot@@stanford.edu} | ||||||||
| #' @export | ||||||||
| matplotlib <- function(dmin, dmax, m) | ||||||||
| { | ||||||||
| steps <- c(1,2,5,10) | ||||||||
| nbins <- m | ||||||||
| trim <- TRUE | ||||||||
| vmin <- dmin | ||||||||
| vmax <- dmax | ||||||||
| params <- .matplotlib.scale.range(vmin, vmax, nbins) | ||||||||
| scale <- params[1] | ||||||||
| offset <- params[2] | ||||||||
| vmin <- vmin-offset | ||||||||
| vmax <- vmax-offset | ||||||||
| rawStep <- (vmax-vmin)/nbins | ||||||||
| scaledRawStep <- rawStep/scale | ||||||||
| bestMax <- vmax | ||||||||
| bestMin <- vmin | ||||||||
| scaledStep <- 1 | ||||||||
| chosenFactor <- 1 | ||||||||
| for (step in steps) | ||||||||
| { | ||||||||
| if (step >= scaledRawStep) | ||||||||
| { | ||||||||
| scaledStep <- step*scale | ||||||||
| chosenFactor <- step | ||||||||
| bestMin <- scaledStep * floor(vmin/scaledStep) | ||||||||
| bestMax <- bestMin + scaledStep*nbins | ||||||||
| if (bestMax >= vmax) | ||||||||
| break | ||||||||
| } | ||||||||
| } | ||||||||
| if (trim) | ||||||||
| { | ||||||||
| extraBins <- floor((bestMax-vmax)/scaledStep) | ||||||||
| nbins <- nbins-extraBins | ||||||||
| } | ||||||||
| graphMin <- bestMin+offset | ||||||||
| graphMax <- graphMin+nbins*scaledStep | ||||||||
| seq(from=graphMin, to=graphMax, by=scaledStep) | ||||||||
| } | ||||||||
| .matplotlib.scale.range <- function(min, max, bins) | ||||||||
| { | ||||||||
| threshold <- 100 | ||||||||
| dv <- abs(max-min) | ||||||||
| maxabsv<-max(abs(min), abs(max)) | ||||||||
| if (maxabsv == 0 || dv/maxabsv<10^-12) | ||||||||
| return(c(1, 0)) | ||||||||
| meanv <- 0.5*(min+max) | ||||||||
| if ((abs(meanv)/dv) < threshold) | ||||||||
| offset<- 0 | ||||||||
| else if (meanv>0) | ||||||||
| { | ||||||||
| exp<-floor(log10(meanv)) | ||||||||
| offset = 10.0^exp | ||||||||
| } else | ||||||||
| { | ||||||||
| exp <- floor(log10(-1*meanv)) | ||||||||
| offset <- -10.0^exp | ||||||||
| } | ||||||||
| exp <- floor(log10(dv/bins)) | ||||||||
| scale = 10.0^exp | ||||||||
| c(scale, offset) | ||||||||
| } | ||||||||
| #' gnuplot's labeling algorithm | ||||||||
| #' | ||||||||
| #' @param dmin minimum of the data range | ||||||||
| #' @param dmax maximum of the data range | ||||||||
| #' @param m number of axis labels | ||||||||
| #' @return vector of axis label locations | ||||||||
| #' @references | ||||||||
| #' \url{http://www.gnuplot.info/} | ||||||||
| #' @author Justin Talbot \email{jtalbot@@stanford.edu} | ||||||||
| #' @export | ||||||||
| gnuplot <- function(dmin, dmax, m) | ||||||||
| { | ||||||||
| ntick <- floor(m) | ||||||||
| power <- 10^floor(log10(dmax-dmin)) | ||||||||
| norm_range <- (dmax-dmin)/power | ||||||||
| p <- (ntick-1) / norm_range | ||||||||
| if(p > 40) | ||||||||
| t <- 0.05 | ||||||||
| else if(p > 20) | ||||||||
| t <- 0.1 | ||||||||
| else if(p > 10) | ||||||||
| t <- 0.2 | ||||||||
| else if(p > 4) | ||||||||
| t <- 0.5 | ||||||||
| else if(p > 2) | ||||||||
| t <- 1 | ||||||||
| else if(p > 0.5) | ||||||||
| t <- 2 | ||||||||
| else | ||||||||
| t <- ceiling(norm_range) | ||||||||
| d <- t*power | ||||||||
| graphmin <- floor(dmin/d) * d | ||||||||
| graphmax <- ceiling(dmax/d) * d | ||||||||
| seq(from=graphmin, to=graphmax, by=d) | ||||||||
| } | ||||||||
| #' Sparks' labeling algorithm | ||||||||
| #' | ||||||||
| #' @param dmin minimum of the data range | ||||||||
| #' @param dmax maximum of the data range | ||||||||
| #' @param m number of axis labels | ||||||||
| #' @return vector of axis label locations | ||||||||
| #' @references | ||||||||
| #' Sparks, D. N. (1971) AS 44. Scatter Diagram Plotting, Journal of the Royal Statistical Society. Series C., pp. 327-331. | ||||||||
| #' @author Justin Talbot \email{jtalbot@@stanford.edu} | ||||||||
| #' @export | ||||||||
| sparks <- function(dmin, dmax, m) | ||||||||
| { | ||||||||
| fm <- m-1 | ||||||||
| ratio <- 0 | ||||||||
| key <- 1 | ||||||||
| kount <- 0 | ||||||||
| r <- dmax-dmin | ||||||||
| b <- dmin | ||||||||
| while(ratio <= 0.8) | ||||||||
| { | ||||||||
| while(key <= 2) | ||||||||
| { | ||||||||
| while(r <= 1) | ||||||||
| { | ||||||||
| kount <- kount + 1 | ||||||||
| r <- r*10 | ||||||||
| } | ||||||||
| while(r > 10) | ||||||||
| { | ||||||||
| kount <- kount - 1 | ||||||||
| r <- r/10 | ||||||||
| } | ||||||||
| b <- b*(10^kount) | ||||||||
| if( b < 0 && b != trunc(b)) b <- b-1 | ||||||||
| b <- trunc(b)/(10^kount) | ||||||||
| r <- (dmax-b)/fm | ||||||||
| kount <- 0 | ||||||||
| key <- key+2 | ||||||||
| } | ||||||||
| fstep <- trunc(r) | ||||||||
| if(fstep != r) fstep <- fstep+1 | ||||||||
| if(r < 1.5) fstep <- fstep-0.5 | ||||||||
| fstep <- fstep/(10^kount) | ||||||||
| ratio <- (dmax - dmin)*(fm*fstep) | ||||||||
| kount <- 1 | ||||||||
| key <- 2 | ||||||||
| } | ||||||||
| fmin <- b | ||||||||
| c <- fstep*trunc(b/fstep) | ||||||||
| if(c < 0 && c != b) c <- c-fstep | ||||||||
| if((c+fm*fstep) > dmax) fmin <- c | ||||||||
| seq(from=fmin, to=fstep*(m-1), by=fstep) | ||||||||
| } | ||||||||
| #' Thayer and Storer's labeling algorithm | ||||||||
| #' | ||||||||
| #' @param dmin minimum of the data range | ||||||||
| #' @param dmax maximum of the data range | ||||||||
| #' @param m number of axis labels | ||||||||
| #' @return vector of axis label locations | ||||||||
| #' @references | ||||||||
| #' Thayer, R. P. and Storer, R. F. (1969) AS 21. Scale Selection for Computer Plots, Journal of the Royal Statistical Society. Series C., pp. 206-208. | ||||||||
| #' @author Justin Talbot \email{jtalbot@@stanford.edu} | ||||||||
| #' @export | ||||||||
| thayer <- function(dmin, dmax, m) | ||||||||
| { | ||||||||
| r <- dmax-dmin | ||||||||
| b <- dmin | ||||||||
| kount <- 0 | ||||||||
| kod <- 0 | ||||||||
| while(kod < 2) | ||||||||
| { | ||||||||
| while(r <= 1) | ||||||||
| { | ||||||||
| kount <- kount+1 | ||||||||
| r <- r*10 | ||||||||
| } | ||||||||
| while(r > 10) | ||||||||
| { | ||||||||
| kount <- kount-1 | ||||||||
| r <- r/10 | ||||||||
| } | ||||||||
| b <- b*(10^kount) | ||||||||
| if(b < 0) | ||||||||
| b <- b-1 | ||||||||
| ib <- trunc(b) | ||||||||
| b <- ib | ||||||||
| b <- b/(10^kount) | ||||||||
| r <- dmax-b | ||||||||
| a <- r/(m-1) | ||||||||
| kount <- 0 | ||||||||
| while(a <= 1) | ||||||||
| { | ||||||||
| kount <- kount+1 | ||||||||
| a <- a*10 | ||||||||
| } | ||||||||
| while(a > 10) | ||||||||
| { | ||||||||
| kount <- kount-1 | ||||||||
| a <- a/10 | ||||||||
| } | ||||||||
| ia <- trunc(a) | ||||||||
| if(ia == 6) ia <- 7 | ||||||||
| if(ia == 8) ia <- 9 | ||||||||
| aa <- 0 | ||||||||
| if(a < 1.5) aa <- -0.5 | ||||||||
| a <- aa + 1 + ia | ||||||||
| a <- a/(10^kount) | ||||||||
| test <- (m-1) * a | ||||||||
| test1 <- (dmax-dmin)/test | ||||||||
| if(test1 > 0.8) | ||||||||
| kod <- 2 | ||||||||
| if(kod < 2) | ||||||||
| { | ||||||||
| kount <- 1 | ||||||||
| r <- dmax-dmin | ||||||||
| b <- dmin | ||||||||
| kod <- kod + 1 | ||||||||
| } | ||||||||
| } | ||||||||
| iab <- trunc(b/a) | ||||||||
| if(iab < 0) iab <- iab-1 | ||||||||
| c <- a * iab | ||||||||
| d <- c + (m-1)*a | ||||||||
| if(d >= dmax) | ||||||||
| b <- c | ||||||||
| valmin <- b | ||||||||
| valmax <- b + a*(m-1) | ||||||||
| seq(from=valmin, to=valmax, by=a) | ||||||||
| } | ||||||||
| scales/R/breaks.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Equally spaced breaks | ||||||||
| #' | ||||||||
| #' Useful for numeric, date, and date-time scales. | ||||||||
| #' | ||||||||
| #' @param width Distance between each break. Either a number, or for | ||||||||
| #' date/times, a single string of the form "{n} {unit}", e.g. "1 month", | ||||||||
| #' "5 days". Unit can be of one "sec", "min", "hour", "day", "week", | ||||||||
| #' "month", "year". | ||||||||
| #' @param offset Use if you don't want breaks to start at zero | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' demo_continuous(c(0, 100)) | ||||||||
| #' demo_continuous(c(0, 100), breaks = breaks_width(10)) | ||||||||
| #' demo_continuous(c(0, 100), breaks = breaks_width(20, -4)) | ||||||||
| #' demo_continuous(c(0, 100), breaks = breaks_width(20, 4)) | ||||||||
| #' | ||||||||
| #' # This is also useful for dates | ||||||||
| #' one_month <- as.POSIXct(c("2020-05-01", "2020-06-01")) | ||||||||
| #' demo_datetime(one_month) | ||||||||
| #' demo_datetime(one_month, breaks = breaks_width("1 week")) | ||||||||
| #' demo_datetime(one_month, breaks = breaks_width("5 days")) | ||||||||
| #' # This is so useful that scale_x_datetime() has a shorthand: | ||||||||
| #' demo_datetime(one_month, date_breaks = "5 days") | ||||||||
| #' | ||||||||
| #' # hms times also work | ||||||||
| #' one_hour <- hms::hms(hours = 0:1) | ||||||||
| #' demo_time(one_hour) | ||||||||
| #' demo_time(one_hour, breaks = breaks_width("15 min")) | ||||||||
| #' demo_time(one_hour, breaks = breaks_width("600 sec")) | ||||||||
| breaks_width <- function(width, offset = 0) { | ||||||||
| force_all(width, offset) | ||||||||
| function(x) { | ||||||||
| fullseq(x, width) + offset | ||||||||
| } | ||||||||
| } | ||||||||
| #' Automatic breaks for numeric axes | ||||||||
| #' | ||||||||
| #' Uses Wilkinson's extended breaks algorithm as implemented in the | ||||||||
| #' \pkg{labeling} package. | ||||||||
| #' | ||||||||
| #' @param n Desired number of breaks. You may get slightly more or fewer | ||||||||
| #' breaks that requested. | ||||||||
| #' @param ... other arguments passed on to [labeling::extended()] | ||||||||
| #' @references Talbot, J., Lin, S., Hanrahan, P. (2010) An Extension of | ||||||||
| #' Wilkinson's Algorithm for Positioning Tick Labels on Axes, InfoVis | ||||||||
| #' 2010 <http://vis.stanford.edu/files/2010-TickLabels-InfoVis.pdf>. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' demo_continuous(c(0, 10)) | ||||||||
| #' demo_continuous(c(0, 10), breaks = breaks_extended(3)) | ||||||||
| #' demo_continuous(c(0, 10), breaks = breaks_extended(10)) | ||||||||
| breaks_extended <- function(n = 5, ...) { | ||||||||
| n_default <- n | ||||||||
| function(x, n = n_default) { | ||||||||
| x <- x[is.finite(x)] | ||||||||
| if (length(x) == 0) { | ||||||||
| return(numeric()) | ||||||||
| } | ||||||||
| rng <- range(x) | ||||||||
| labeling::extended(rng[1], rng[2], n, ...) | ||||||||
| } | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @usage NULL | ||||||||
| #' @rdname breaks_extended | ||||||||
| extended_breaks <- breaks_extended | ||||||||
| #' Pretty breaks for date/times | ||||||||
| #' | ||||||||
| #' Uses default R break algorithm as implemented in [pretty()]. This is | ||||||||
| #' primarily useful for date/times, as [extended_breaks()] should do a slightly | ||||||||
| #' better job for numeric scales. | ||||||||
| #' | ||||||||
| #' `pretty_breaks()` is retired; use `breaks_pretty()` instead. | ||||||||
| #' | ||||||||
| #' @inheritParams breaks_extended | ||||||||
| #' @param ... other arguments passed on to [pretty()] | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' one_month <- as.POSIXct(c("2020-05-01", "2020-06-01")) | ||||||||
| #' demo_datetime(one_month) | ||||||||
| #' demo_datetime(one_month, breaks = breaks_pretty(2)) | ||||||||
| #' demo_datetime(one_month, breaks = breaks_pretty(4)) | ||||||||
| #' | ||||||||
| #' # Tightly spaced date breaks often need custom labels too | ||||||||
| #' demo_datetime(one_month, breaks = breaks_pretty(12)) | ||||||||
| #' demo_datetime(one_month, | ||||||||
| #' breaks = breaks_pretty(12), | ||||||||
| #' labels = label_date_short() | ||||||||
| #') | ||||||||
| breaks_pretty <- function(n = 5, ...) { | ||||||||
| force_all(n, ...) | ||||||||
| n_default <- n | ||||||||
| function(x, n = n_default) { | ||||||||
| breaks <- pretty(x, n, ...) | ||||||||
| names(breaks) <- attr(breaks, "labels") | ||||||||
| breaks | ||||||||
| } | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @usage NULL | ||||||||
| #' @rdname breaks_pretty | ||||||||
| pretty_breaks <- breaks_pretty | ||||||||
| ggplot2/R/scale-view.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' View scale constructor | ||||||||
| #' | ||||||||
| #' View scales are an implementation of `Scale` objects that have fixed | ||||||||
| #' limits, dimension, breaks, labels, and minor breaks. They are used as | ||||||||
| #' the immutable result of the trained scales that have been assigned | ||||||||
| #' `limits` and a `continuous_range` from the coordinate system's | ||||||||
| #' implementation of scale expantion. | ||||||||
| #' | ||||||||
| #' @param scale The scale from which to construct a view scale. | ||||||||
| #' @param limits The final scale limits | ||||||||
| #' @param continuous_range The final dimensions of the scale | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| view_scale_primary <- function(scale, limits = scale$get_limits(), | ||||||||
| continuous_range = scale$dimension(limits = limits)) { | ||||||||
| if(!scale$is_discrete()) { | ||||||||
| # continuous_range can be specified in arbitrary order, but | ||||||||
| # continuous scales expect the one in ascending order. | ||||||||
| breaks <- scale$get_breaks(sort(continuous_range)) | ||||||||
| minor_breaks <- scale$get_breaks_minor(b = breaks, limits = continuous_range) | ||||||||
| } else { | ||||||||
| breaks <- scale$get_breaks(limits) | ||||||||
| minor_breaks <- scale$get_breaks_minor(b = breaks, limits = limits) | ||||||||
| } | ||||||||
| ggproto(NULL, ViewScale, | ||||||||
| scale = scale, | ||||||||
| guide = scale$guide, | ||||||||
| position = scale$position, | ||||||||
| aesthetics = scale$aesthetics, | ||||||||
| name = scale$name, | ||||||||
| scale_is_discrete = scale$is_discrete(), | ||||||||
| limits = limits, | ||||||||
| continuous_range = continuous_range, | ||||||||
| breaks = breaks, | ||||||||
| minor_breaks = minor_breaks | ||||||||
| ) | ||||||||
| } | ||||||||
| # this function is a hack that is difficult to avoid given the complex implementation of second axes | ||||||||
| view_scale_secondary <- function(scale, limits = scale$get_limits(), | ||||||||
| continuous_range = scale$dimension(limits = limits)) { | ||||||||
| if (is.null(scale$secondary.axis) || is.waive(scale$secondary.axis) || scale$secondary.axis$empty()) { | ||||||||
| # if there is no second axis, return the primary scale with no guide | ||||||||
| # this guide can be overridden using guides() | ||||||||
| primary_scale <- view_scale_primary(scale, limits, continuous_range) | ||||||||
| scale_flip_position(primary_scale) | ||||||||
| primary_scale$guide <- guide_none() | ||||||||
| primary_scale | ||||||||
| } else { | ||||||||
| scale$secondary.axis$init(scale) | ||||||||
| break_info <- scale$secondary.axis$break_info(continuous_range, scale) | ||||||||
| names(break_info) <- gsub("sec\\.", "", names(break_info)) | ||||||||
| # flip position from the original scale by default | ||||||||
| # this can (should) be overridden in the guide | ||||||||
| position <- switch(scale$position, | ||||||||
| top = "bottom", | ||||||||
| bottom = "top", | ||||||||
| left = "right", | ||||||||
| right = "left", | ||||||||
| scale$position | ||||||||
| ) | ||||||||
| ggproto(NULL, ViewScale, | ||||||||
| scale = scale, | ||||||||
| guide = scale$secondary.axis$guide, | ||||||||
| position = position, | ||||||||
| break_info = break_info, | ||||||||
| # as far as scales are concerned, this is a regular scale with | ||||||||
| # different breaks and labels in a different data space | ||||||||
| aesthetics = scale$aesthetics, | ||||||||
| name = scale$sec_name(), | ||||||||
| make_title = function(self, title) self$scale$make_sec_title(title), | ||||||||
| dimension = function(self) self$break_info$range, | ||||||||
| get_limits = function(self) self$break_info$range, | ||||||||
| get_breaks = function(self) self$break_info$major_source, | ||||||||
| get_breaks_minor = function(self) self$break_info$minor_source, | ||||||||
| break_positions = function(self) self$break_info$major, | ||||||||
| break_positions_minor = function(self) self$break_info$minor, | ||||||||
| get_labels = function(self, breaks = self$get_breaks()) self$break_info$labels, | ||||||||
| rescale = function(x) rescale(x, from = break_info$range, to = c(0, 1)) | ||||||||
| ) | ||||||||
| } | ||||||||
| } | ||||||||
| view_scale_empty <- function() { | ||||||||
| ggproto(NULL, ViewScale, | ||||||||
| is_empty = function() TRUE, | ||||||||
| is_discrete = function() NA, | ||||||||
| dimension = function() c(0, 1), | ||||||||
| get_limits = function() c(0, 1), | ||||||||
| get_breaks = function() NULL, | ||||||||
| get_breaks_minor = function() NULL, | ||||||||
| get_labels = function(breaks = NULL) breaks, | ||||||||
| rescale = function(x) abort("Not implemented"), | ||||||||
| map = function(x) abort("Not implemented"), | ||||||||
| make_title = function(title) title, | ||||||||
| break_positions = function() NULL, | ||||||||
| break_positions_minor = function() NULL | ||||||||
| ) | ||||||||
| } | ||||||||
| ViewScale <- ggproto("ViewScale", NULL, | ||||||||
| # map, rescale, and make_title need a reference | ||||||||
| # to the original scale | ||||||||
| scale = ggproto(NULL, Scale), | ||||||||
| guide = guide_none(), | ||||||||
| position = NULL, | ||||||||
| aesthetics = NULL, | ||||||||
| name = waiver(), | ||||||||
| scale_is_discrete = FALSE, | ||||||||
| limits = NULL, | ||||||||
| continuous_range = NULL, | ||||||||
| breaks = NULL, | ||||||||
| minor_breaks = NULL, | ||||||||
| is_empty = function(self) { | ||||||||
| is.null(self$get_breaks()) && is.null(self$get_breaks_minor()) | ||||||||
| }, | ||||||||
| is_discrete = function(self) self$scale_is_discrete, | ||||||||
| dimension = function(self) self$continuous_range, | ||||||||
| get_limits = function(self) self$limits, | ||||||||
| get_breaks = function(self) self$breaks, | ||||||||
| get_breaks_minor = function(self) self$minor_breaks, | ||||||||
| get_labels = function(self, breaks = self$get_breaks()) self$scale$get_labels(breaks), | ||||||||
| rescale = function(self, x) { | ||||||||
| self$scale$rescale(x, self$limits, self$continuous_range) | ||||||||
| }, | ||||||||
| map = function(self, x) { | ||||||||
| if (self$is_discrete()) { | ||||||||
| self$scale$map(x, self$limits) | ||||||||
| } else { | ||||||||
| self$scale$map(x, self$continuous_range) | ||||||||
| } | ||||||||
| }, | ||||||||
| make_title = function(self, title) { | ||||||||
| self$scale$make_title(title) | ||||||||
| }, | ||||||||
| break_positions = function(self) { | ||||||||
| self$rescale(self$get_breaks()) | ||||||||
| }, | ||||||||
| break_positions_minor = function(self) { | ||||||||
| b <- self$get_breaks_minor() | ||||||||
| if (is.null(b)) { | ||||||||
| return(NULL) | ||||||||
| } | ||||||||
| self$rescale(b) | ||||||||
| } | ||||||||
| ) | ||||||||
| 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$dimension(), panel_params$y$dimension()) | ||||||||
| dist_euclidean(x, y) / max_dist | ||||||||
| }, | ||||||||
| range = function(panel_params) { | ||||||||
| list(x = panel_params$x$dimension(), y = panel_params$y$dimension()) | ||||||||
| }, | ||||||||
| backtransform_range = function(self, panel_params) { | ||||||||
| self$range(panel_params) | ||||||||
| }, | ||||||||
| transform = function(data, panel_params) { | ||||||||
| data <- transform_position(data, panel_params$x$rescale, panel_params$y$rescale) | ||||||||
| transform_position(data, squish_infinite, squish_infinite) | ||||||||
| }, | ||||||||
| setup_panel_params = function(self, scale_x, scale_y, params = list()) { | ||||||||
| c( | ||||||||
| view_scales_from_scale(scale_x, self$limits$x, self$expand), | ||||||||
| view_scales_from_scale(scale_y, self$limits$y, self$expand) | ||||||||
| ) | ||||||||
| }, | ||||||||
| setup_panel_guides = function(self, panel_params, guides, params = list()) { | ||||||||
| aesthetics <- c("x", "y", "x.sec", "y.sec") | ||||||||
| names(aesthetics) <- aesthetics | ||||||||
| # resolve the specified guide from the scale and/or guides | ||||||||
| guides <- lapply(aesthetics, function(aesthetic) { | ||||||||
| resolve_guide( | ||||||||
| aesthetic, | ||||||||
| panel_params[[aesthetic]], | ||||||||
| guides, | ||||||||
| default = guide_axis(), | ||||||||
| null = guide_none() | ||||||||
| ) | ||||||||
| }) | ||||||||
| # resolve the guide definition as a "guide" S3 | ||||||||
| guides <- lapply(guides, validate_guide) | ||||||||
| # if there is an "position" specification in the scale, pass this on to the guide | ||||||||
| # ideally, this should be specified in the guide | ||||||||
| guides <- lapply(aesthetics, function(aesthetic) { | ||||||||
| guide <- guides[[aesthetic]] | ||||||||
| scale <- panel_params[[aesthetic]] | ||||||||
| # position could be NULL here for an empty scale | ||||||||
| guide$position <- guide$position %|W|% scale$position | ||||||||
| guide | ||||||||
| }) | ||||||||
| panel_params$guides <- guides | ||||||||
| panel_params | ||||||||
| }, | ||||||||
| train_panel_guides = function(self, panel_params, layers, default_mapping, params = list()) { | ||||||||
| aesthetics <- c("x", "y", "x.sec", "y.sec") | ||||||||
| names(aesthetics) <- aesthetics | ||||||||
| panel_params$guides <- lapply(aesthetics, function(aesthetic) { | ||||||||
| axis <- substr(aesthetic, 1, 1) | ||||||||
| guide <- panel_params$guides[[aesthetic]] | ||||||||
| guide <- guide_train(guide, panel_params[[aesthetic]]) | ||||||||
| guide <- guide_transform(guide, self, panel_params) | ||||||||
| guide <- guide_geom(guide, layers, default_mapping) | ||||||||
| guide | ||||||||
| }) | ||||||||
| panel_params | ||||||||
| }, | ||||||||
| labels = function(self, labels, panel_params) { | ||||||||
| positions_x <- c("top", "bottom") | ||||||||
| positions_y <- c("left", "right") | ||||||||
| list( | ||||||||
| x = lapply(c(1, 2), function(i) { | ||||||||
| panel_guide_label( | ||||||||
| panel_params$guides, | ||||||||
| position = positions_x[[i]], | ||||||||
| default_label = labels$x[[i]] | ||||||||
| ) | ||||||||
| }), | ||||||||
| y = lapply(c(1, 2), function(i) { | ||||||||
| panel_guide_label( | ||||||||
| panel_params$guides, | ||||||||
| position = positions_y[[i]], | ||||||||
| default_label = labels$y[[i]]) | ||||||||
| }) | ||||||||
| ) | ||||||||
| }, | ||||||||
| render_bg = function(panel_params, theme) { | ||||||||
| guide_grid( | ||||||||
| theme, | ||||||||
| panel_params$x$break_positions_minor(), | ||||||||
| panel_params$x$break_positions(), | ||||||||
| panel_params$y$break_positions_minor(), | ||||||||
| panel_params$y$break_positions() | ||||||||
| ) | ||||||||
| }, | ||||||||
| render_axis_h = function(panel_params, theme) { | ||||||||
| list( | ||||||||
| top = panel_guides_grob(panel_params$guides, position = "top", theme = theme), | ||||||||
| bottom = panel_guides_grob(panel_params$guides, position = "bottom", theme = theme) | ||||||||
| ) | ||||||||
| }, | ||||||||
| render_axis_v = function(panel_params, theme) { | ||||||||
| list( | ||||||||
| left = panel_guides_grob(panel_params$guides, position = "left", theme = theme), | ||||||||
| right = panel_guides_grob(panel_params$guides, position = "right", theme = theme) | ||||||||
| ) | ||||||||
| } | ||||||||
| ) | ||||||||
| view_scales_from_scale <- function(scale, coord_limits = NULL, expand = TRUE) { | ||||||||
| expansion <- default_expansion(scale, expand = expand) | ||||||||
| limits <- scale$get_limits() | ||||||||
| continuous_range <- expand_limits_scale(scale, expansion, limits, coord_limits = coord_limits) | ||||||||
| aesthetic <- scale$aesthetics[1] | ||||||||
| view_scales <- list( | ||||||||
| view_scale_primary(scale, limits, continuous_range), | ||||||||
| sec = view_scale_secondary(scale, limits, continuous_range), | ||||||||
| arrange = scale$axis_order(), | ||||||||
| range = continuous_range | ||||||||
| ) | ||||||||
| names(view_scales) <- c(aesthetic, paste0(aesthetic, ".", names(view_scales)[-1])) | ||||||||
| view_scales | ||||||||
| } | ||||||||
| panel_guide_label <- function(guides, position, default_label) { | ||||||||
| guide <- guide_for_position(guides, position) %||% guide_none(title = NULL) | ||||||||
| guide$title %|W|% default_label | ||||||||
| } | ||||||||
| panel_guides_grob <- function(guides, position, theme) { | ||||||||
| guide <- guide_for_position(guides, position) %||% guide_none() | ||||||||
| guide_gengrob(guide, theme) | ||||||||
| } | ||||||||
| guide_for_position <- function(guides, position) { | ||||||||
| has_position <- vapply( | ||||||||
| guides, | ||||||||
| function(guide) identical(guide$position, position), | ||||||||
| logical(1) | ||||||||
| ) | ||||||||
| guides <- guides[has_position] | ||||||||
| guides_order <- vapply(guides, function(guide) as.numeric(guide$order)[1], numeric(1)) | ||||||||
| Reduce(guide_merge, guides[order(guides_order)]) | ||||||||
| } | ||||||||
| ggplot2/R/plot-construction.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Add components to a plot | ||||||||
| #' | ||||||||
| #' `+` is the key to constructing sophisticated ggplot2 graphics. It | ||||||||
| #' allows you to start simple, then get more and more complex, checking your | ||||||||
| #' work at each step. | ||||||||
| #' | ||||||||
| #' @section What can you add?: | ||||||||
| #' You can add any of the following types of objects: | ||||||||
| #' | ||||||||
| #' - An [aes()] object replaces the default aesthetics. | ||||||||
| #' - A layer created by a `geom_` or `stat_` function adds a | ||||||||
| #' new layer. | ||||||||
| #' - A `scale` overrides the existing scale. | ||||||||
| #' - A [theme()] modifies the current theme. | ||||||||
| #' - A `coord` overrides the current coordinate system. | ||||||||
| #' - A `facet` specification overrides the current faceting. | ||||||||
| #' | ||||||||
| #' To replace the current default data frame, you must use `%+%`, | ||||||||
| #' due to S3 method precedence issues. | ||||||||
| #' | ||||||||
| #' You can also supply a list, in which case each element of the list will | ||||||||
| #' be added in turn. | ||||||||
| #' | ||||||||
| #' @param e1 An object of class [ggplot()] or a [theme()]. | ||||||||
| #' @param e2 A plot component, as described below. | ||||||||
| #' @seealso [theme()] | ||||||||
| #' @export | ||||||||
| #' @method + gg | ||||||||
| #' @rdname gg-add | ||||||||
| #' @examples | ||||||||
| #' base <- ggplot(mpg, aes(displ, hwy)) + geom_point() | ||||||||
| #' base + geom_smooth() | ||||||||
| #' | ||||||||
| #' # To override the data, you must use %+% | ||||||||
| #' base %+% subset(mpg, fl == "p") | ||||||||
| #' | ||||||||
| #' # Alternatively, you can add multiple components with a list. | ||||||||
| #' # This can be useful to return from a function. | ||||||||
| #' base + list(subset(mpg, fl == "p"), geom_smooth()) | ||||||||
| "+.gg" <- function(e1, e2) { | ||||||||
| if (missing(e2)) { | ||||||||
| abort("Cannot use `+.gg()` with a single argument. Did you accidentally put + on a new line?") | ||||||||
| } | ||||||||
| # Get the name of what was passed in as e2, and pass along so that it | ||||||||
| # can be displayed in error messages | ||||||||
| e2name <- deparse(substitute(e2)) | ||||||||
| if (is.theme(e1)) add_theme(e1, e2, e2name) | ||||||||
| else if (is.ggplot(e1)) add_ggplot(e1, e2, e2name) | ||||||||
| else if (is.ggproto(e1)) { | ||||||||
| abort("Cannot add ggproto objects together. Did you forget to add this object to a ggplot object?") | ||||||||
| } | ||||||||
| } | ||||||||
| #' @rdname gg-add | ||||||||
| #' @export | ||||||||
| "%+%" <- `+.gg` | ||||||||
| add_ggplot <- function(p, object, objectname) { | ||||||||
| if (is.null(object)) return(p) | ||||||||
| p <- plot_clone(p) | ||||||||
| p <- ggplot_add(object, p, objectname) | ||||||||
| set_last_plot(p) | ||||||||
| p | ||||||||
| } | ||||||||
| #' Add custom objects to ggplot | ||||||||
| #' | ||||||||
| #' This generic allows you to add your own methods for adding custom objects to | ||||||||
| #' a ggplot with [+.gg]. | ||||||||
| #' | ||||||||
| #' @param object An object to add to the plot | ||||||||
| #' @param plot The ggplot object to add `object` to | ||||||||
| #' @param object_name The name of the object to add | ||||||||
| #' | ||||||||
| #' @return A modified ggplot object | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| ggplot_add <- function(object, plot, object_name) { | ||||||||
| UseMethod("ggplot_add") | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_add.default <- function(object, plot, object_name) { | ||||||||
| abort(glue("Can't add `{object_name}` to a ggplot object.")) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_add.NULL <- function(object, plot, object_name) { | ||||||||
| plot | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_add.data.frame <- function(object, plot, object_name) { | ||||||||
| plot$data <- object | ||||||||
| plot | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_add.function <- function(object, plot, object_name) { | ||||||||
| abort(glue( | ||||||||
| "Can't add `{object_name}` to a ggplot object.\n", | ||||||||
| "Did you forget to add parentheses, as in `{object_name}()`?" | ||||||||
| )) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_add.theme <- function(object, plot, object_name) { | ||||||||
| plot$theme <- add_theme(plot$theme, object) | ||||||||
| plot | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_add.Scale <- function(object, plot, object_name) { | ||||||||
| plot$scales$add(object) | ||||||||
| plot | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_add.labels <- function(object, plot, object_name) { | ||||||||
| update_labels(plot, object) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_add.guides <- function(object, plot, object_name) { | ||||||||
| update_guides(plot, object) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_add.uneval <- function(object, plot, object_name) { | ||||||||
| plot$mapping <- defaults(object, plot$mapping) | ||||||||
| # defaults() doesn't copy class, so copy it. | ||||||||
| class(plot$mapping) <- class(object) | ||||||||
| labels <- make_labels(object) | ||||||||
| names(labels) <- names(object) | ||||||||
| update_labels(plot, labels) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_add.Coord <- function(object, plot, object_name) { | ||||||||
| if (!isTRUE(plot$coordinates$default)) { | ||||||||
| message( | ||||||||
| "Coordinate system already present. Adding new coordinate ", | ||||||||
| "system, which will replace the existing one." | ||||||||
| ) | ||||||||
| } | ||||||||
| plot$coordinates <- object | ||||||||
| plot | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_add.Facet <- function(object, plot, object_name) { | ||||||||
| plot$facet <- object | ||||||||
| plot | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_add.list <- function(object, plot, object_name) { | ||||||||
| for (o in object) { | ||||||||
| plot <- plot %+% o | ||||||||
| } | ||||||||
| plot | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_add.by <- function(object, plot, object_name) { | ||||||||
| ggplot_add.list(object, plot, object_name) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| ggplot_add.Layer <- function(object, plot, object_name) { | ||||||||
| plot$layers <- append(plot$layers, object) | ||||||||
| # Add any new labels | ||||||||
| mapping <- make_labels(object$mapping) | ||||||||
| default <- make_labels(object$stat$default_aes) | ||||||||
| new_labels <- defaults(mapping, default) | ||||||||
| plot$labels <- defaults(plot$labels, new_labels) | ||||||||
| plot | ||||||||
| } | ||||||||
| 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. Use the themes available in [complete | ||||||||
| #' themes][theme_bw] if you would like to use a complete theme such as | ||||||||
| #' `theme_bw()`, `theme_minimal()`, and more. 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 hierarchically. | ||||||||
| #' 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,axis.ticks.length.x,axis.ticks.length.x.top,axis.ticks.length.x.bottom,axis.ticks.length.y,axis.ticks.length.y.left,axis.ticks.length.y.right | ||||||||
| #' 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.title.position,plot.caption.position Alignment of the plot title/subtitle | ||||||||
| #' and caption. The setting for `plot.title.position` applies to both | ||||||||
| #' the title and the subtitle. A value of "panel" (the default) means that | ||||||||
| #' titles and/or caption are aligned to the plot panels. A value of "plot" means | ||||||||
| #' that titles and/or caption are aligned to the entire plot (minus any space | ||||||||
| #' for margins and plot tag). | ||||||||
| #' @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. In general, | ||||||||
| #' these should also be defined in the `element tree` argument. | ||||||||
| #' @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 [%+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 ---------------------------------------------------------------------- | ||||||||
| #' # Change styles of axes texts and lines | ||||||||
| #' 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)) | ||||||||
| #' | ||||||||
| #' # Change the appearance of the y-axis title | ||||||||
| #' p1 + theme(axis.title.y = element_text(size = rel(1.5), angle = 90)) | ||||||||
| #' | ||||||||
| #' # Make ticks point outwards on y-axis and inwards on x-axis | ||||||||
| #' p1 + theme( | ||||||||
| #' axis.ticks.length.y = unit(.25, "cm"), | ||||||||
| #' axis.ticks.length.x = unit(-.25, "cm"), | ||||||||
| #' axis.text.x = element_text(margin = margin(t = .3, unit = "cm")) | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' \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.ticks.length.x, | ||||||||
| axis.ticks.length.x.top, | ||||||||
| axis.ticks.length.x.bottom, | ||||||||
| axis.ticks.length.y, | ||||||||
| axis.ticks.length.y.left, | ||||||||
| axis.ticks.length.y.right, | ||||||||
| 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.title.position, | ||||||||
| plot.subtitle, | ||||||||
| plot.caption, | ||||||||
| plot.caption.position, | ||||||||
| 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)) { | ||||||||
| warn("`axis.ticks.margin` is deprecated. Please set `margin` property of `axis.text` instead") | ||||||||
| elements$axis.ticks.margin <- NULL | ||||||||
| } | ||||||||
| if (!is.null(elements$panel.margin)) { | ||||||||
| warn("`panel.margin` is deprecated. Please use `panel.spacing` property instead") | ||||||||
| elements$panel.spacing <- elements$panel.margin | ||||||||
| elements$panel.margin <- NULL | ||||||||
| } | ||||||||
| if (!is.null(elements$panel.margin.x)) { | ||||||||
| warn("`panel.margin.x` is deprecated. Please use `panel.spacing.x` property instead") | ||||||||
| elements$panel.spacing.x <- elements$panel.margin.x | ||||||||
| elements$panel.margin.x <- NULL | ||||||||
| } | ||||||||
| if (!is.null(elements$panel.margin.y)) { | ||||||||
| warn("`panel.margin` is deprecated. Please use `panel.spacing` property instead") | ||||||||
| elements$panel.spacing.y <- elements$panel.margin.y | ||||||||
| elements$panel.margin.y <- NULL | ||||||||
| } | ||||||||
| if (is.unit(elements$legend.margin) && !is.margin(elements$legend.margin)) { | ||||||||
| warn("`legend.margin` must be specified using `margin()`. For the old behavior use legend.spacing") | ||||||||
| elements$legend.spacing <- elements$legend.margin | ||||||||
| elements$legend.margin <- margin() | ||||||||
| } | ||||||||
| # 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 | ||||||||
| ) | ||||||||
| } | ||||||||
| # check whether theme is complete | ||||||||
| is_theme_complete <- function(x) isTRUE(attr(x, "complete", exact = TRUE)) | ||||||||
| # check whether theme should be validated | ||||||||
| is_theme_validate <- function(x) { | ||||||||
| validate <- attr(x, "validate", exact = TRUE) | ||||||||
| if (is.null(validate)) | ||||||||
| TRUE # we validate by default | ||||||||
| else | ||||||||
| isTRUE(validate) | ||||||||
| } | ||||||||
| # Combine plot defaults with current theme to get complete theme for a plot | ||||||||
| plot_theme <- function(x, default = theme_get()) { | ||||||||
| theme <- x$theme | ||||||||
| # apply theme defaults appropriately if needed | ||||||||
| if (is_theme_complete(theme)) { | ||||||||
| # for complete themes, we fill in missing elements but don't do any element merging | ||||||||
| # can't use `defaults()` because it strips attributes | ||||||||
| missing <- setdiff(names(default), names(theme)) | ||||||||
| theme[missing] <- default[missing] | ||||||||
| } else { | ||||||||
| # otherwise, we can just add the theme to the default theme | ||||||||
| theme <- default + theme | ||||||||
| } | ||||||||
| # if we're still missing elements relative to fallback default, fill in those | ||||||||
| missing <- setdiff(names(ggplot_global$theme_default), names(theme)) | ||||||||
| theme[missing] <- ggplot_global$theme_default[missing] | ||||||||
| # Check that all elements have the correct class (element_text, unit, etc) | ||||||||
| if (is_theme_validate(theme)) { | ||||||||
| mapply( | ||||||||
| validate_element, theme, names(theme), | ||||||||
| MoreArgs = list(element_tree = get_element_tree()) | ||||||||
| ) | ||||||||
| } | ||||||||
| theme | ||||||||
| } | ||||||||
| #' 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.list(t2)) { # in various places in the code base, simple lists are used as themes | ||||||||
| abort(glue("Can't add `{t2name}` to a theme object.")) | ||||||||
| } | ||||||||
| # If t2 is a complete theme or t1 is NULL, just return t2 | ||||||||
| if (is_theme_complete(t2) || is.null(t1)) | ||||||||
| return(t2) | ||||||||
| # Iterate over the elements that are to be updated | ||||||||
| for (item in names(t2)) { | ||||||||
| x <- merge_element(t2[[item]], t1[[item]]) | ||||||||
| # 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) | ||||||||
| } | ||||||||
| # make sure the "complete" attribute is set; this can be missing | ||||||||
| # when t1 is an empty list | ||||||||
| attr(t1, "complete") <- is_theme_complete(t1) | ||||||||
| # Only validate if both themes should be validated | ||||||||
| attr(t1, "validate") <- | ||||||||
| is_theme_validate(t1) && is_theme_validate(t2) | ||||||||
| t1 | ||||||||
| } | ||||||||
| #' 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 | ||||||||
| #' @param skip_blank If TRUE, elements of type `element_blank` in the | ||||||||
| #' inheritance hierarchy will be ignored. | ||||||||
| #' @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, skip_blank = FALSE) { | ||||||||
| if (verbose) message(element, " --> ", appendLF = FALSE) | ||||||||
| el_out <- theme[[element]] | ||||||||
| # If result is element_blank, we skip it if `skip_blank` is `TRUE`, | ||||||||
| # and otherwise we don't inherit anything from parents | ||||||||
| if (inherits(el_out, "element_blank")) { | ||||||||
| if (isTRUE(skip_blank)) { | ||||||||
| el_out <- NULL | ||||||||
| } else { | ||||||||
| if (verbose) message("element_blank (no inheritance)") | ||||||||
| return(el_out) | ||||||||
| } | ||||||||
| } | ||||||||
| # Obtain the element tree | ||||||||
| element_tree <- get_element_tree() | ||||||||
| # If the element is defined (and not just inherited), check that | ||||||||
| # it is of the class specified in element_tree | ||||||||
| if (!is.null(el_out) && | ||||||||
| !inherits(el_out, element_tree[[element]]$class)) { | ||||||||
| abort(glue("{element} should have class {ggplot_global$element_tree[[element]]$class}")) | ||||||||
| } | ||||||||
| # Get the names of parents from the inheritance tree | ||||||||
| pnames <- element_tree[[element]]$inherit | ||||||||
| # If no parents, this is a "root" node. Just return this element. | ||||||||
| if (is.null(pnames)) { | ||||||||
| if (verbose) message("nothing (top level)") | ||||||||
| # Check that all the properties of this element are non-NULL | ||||||||
| nullprops <- vapply(el_out, is.null, logical(1)) | ||||||||
| if (!any(nullprops)) { | ||||||||
| return(el_out) # no null properties, return element as is | ||||||||
| } | ||||||||
| # if we have null properties, try to fill in from ggplot_global$theme_default | ||||||||
| el_out <- combine_elements(el_out, ggplot_global$theme_default[[element]]) | ||||||||
| nullprops <- vapply(el_out, is.null, logical(1)) | ||||||||
| if (!any(nullprops)) { | ||||||||
| return(el_out) # no null properties remaining, return element | ||||||||
| } | ||||||||
| abort(glue("Theme element `{element}` has NULL property without default: ", | ||||||||
| glue_collapse(names(nullprops)[nullprops], ", ", last = " and "))) | ||||||||
| } | ||||||||
| # Calculate the parent objects' inheritance | ||||||||
| if (verbose) message(paste(pnames, collapse = ", ")) | ||||||||
| parents <- lapply( | ||||||||
| pnames, | ||||||||
| calc_element, | ||||||||
| theme, | ||||||||
| verbose = verbose, | ||||||||
| # once we've started skipping blanks, we continue doing so until the end of the | ||||||||
| # recursion; we initiate skipping blanks if we encounter an element that | ||||||||
| # doesn't inherit blank. | ||||||||
| skip_blank = skip_blank || (!is.null(el_out) && !isTRUE(el_out$inherit.blank)) | ||||||||
| ) | ||||||||
| # Combine the properties of this element with all parents | ||||||||
| Reduce(combine_elements, parents, el_out) | ||||||||
| } | ||||||||
| #' 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) { | ||||||||
| if (is.null(old) || inherits(old, "element_blank")) { | ||||||||
| # If old is NULL or element_blank, then just return new | ||||||||
| return(new) | ||||||||
| } else if (is.null(new) || is.character(new) || is.numeric(new) || is.unit(new) || | ||||||||
| is.logical(new)) { | ||||||||
| # If new is NULL, or a string, numeric vector, unit, or logical, just return it | ||||||||
| return(new) | ||||||||
| } | ||||||||
| # otherwise we can't merge | ||||||||
| abort(glue("No method for merging {class(new)[1]} into {class(old)[1]}")) | ||||||||
| } | ||||||||
| #' @rdname merge_element | ||||||||
| #' @export | ||||||||
| merge_element.element_blank <- function(new, old) { | ||||||||
| # If new is element_blank, just return it | ||||||||
| new | ||||||||
| } | ||||||||
| #' @rdname merge_element | ||||||||
| #' @export | ||||||||
| merge_element.element <- function(new, old) { | ||||||||
| if (is.null(old) || inherits(old, "element_blank")) { | ||||||||
| # If old is NULL or element_blank, then just return new | ||||||||
| return(new) | ||||||||
| } | ||||||||
| # actual merging can only happen if classes match | ||||||||
| if (!inherits(new, class(old)[1])) { | ||||||||
| abort("Only elements of the same class can be merged") | ||||||||
| } | ||||||||
| # 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 from which e1 inherits | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| #' | ||||||||
| 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 neither of e1 or e2 are element_* objects, return e1 | ||||||||
| if (!inherits(e1, "element") && !inherits(e2, "element")) { | ||||||||
| return(e1) | ||||||||
| } | ||||||||
| # 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 <- names(e1)[vapply(e1, 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) | ||||||||
| scales/R/colour-manip.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Modify standard R colour in hcl colour space. | ||||||||
| #' | ||||||||
| #' Transforms rgb to hcl, sets non-missing arguments and then backtransforms | ||||||||
| #' to rgb. | ||||||||
| #' | ||||||||
| #' @param colour character vector of colours to be modified | ||||||||
| #' @param h Hue, `[0, 360]` | ||||||||
| #' @param l Luminance, `[0, 100]` | ||||||||
| #' @param c Chroma, `[0, 100]` | ||||||||
| #' @param alpha Alpha, `[0, 1]`. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' reds <- rep("red", 6) | ||||||||
| #' show_col(col2hcl(reds, h = seq(0, 180, length = 6))) | ||||||||
| #' show_col(col2hcl(reds, c = seq(0, 80, length = 6))) | ||||||||
| #' show_col(col2hcl(reds, l = seq(0, 100, length = 6))) | ||||||||
| #' show_col(col2hcl(reds, alpha = seq(0, 1, length = 6))) | ||||||||
| col2hcl <- function(colour, h = NULL, c = NULL, l = NULL, alpha = NULL) { | ||||||||
| hcl <- farver::decode_colour(colour, to = "hcl") | ||||||||
| if (!is.null(h)) hcl[, "h"] <- h | ||||||||
| if (!is.null(c)) hcl[, "c"] <- c | ||||||||
| if (!is.null(l)) hcl[, "l"] <- l | ||||||||
| farver::encode_colour(hcl, alpha, from = "hcl") | ||||||||
| } | ||||||||
| #' Mute standard colour | ||||||||
| #' | ||||||||
| #' @param colour character vector of colours to modify | ||||||||
| #' @param l new luminance | ||||||||
| #' @param c new chroma | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' muted("red") | ||||||||
| #' muted("blue") | ||||||||
| #' show_col(c("red", "blue", muted("red"), muted("blue"))) | ||||||||
| muted <- function(colour, l=30, c=70) col2hcl(colour, l = l, c = c) | ||||||||
| #' Modify colour transparency | ||||||||
| #' | ||||||||
| #' Vectorised in both colour and alpha. | ||||||||
| #' | ||||||||
| #' @param colour colour | ||||||||
| #' @param alpha new alpha level in \[0,1]. If alpha is `NA`, | ||||||||
| #' existing alpha values are preserved. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' alpha("red", 0.1) | ||||||||
| #' alpha(colours(), 0.5) | ||||||||
| #' alpha("red", seq(0, 1, length.out = 10)) | ||||||||
| #' alpha(c("first" = "gold", "second" = "lightgray", "third" = "#cd7f32"), .5) | ||||||||
| alpha <- function(colour, alpha = NA) { | ||||||||
| if (length(colour) != length(alpha)) { | ||||||||
| if (length(colour) > 1 && length(alpha) > 1) { | ||||||||
| stop("Only one of colour and alpha can be vectorised") | ||||||||
| } | ||||||||
| if (length(colour) > 1) { | ||||||||
| alpha <- rep(alpha, length.out = length(colour)) | ||||||||
| } else { | ||||||||
| colour <- rep(colour, length.out = length(alpha)) | ||||||||
| } | ||||||||
| } | ||||||||
| rgb <- farver::decode_colour(colour, alpha = TRUE) | ||||||||
| rgb[!is.na(alpha), 4] <- alpha[!is.na(alpha)] | ||||||||
| farver::encode_colour(rgb, rgb[, 4]) | ||||||||
| } | ||||||||
| #' Show colours | ||||||||
| #' | ||||||||
| #' A quick and dirty way to show colours in a plot. | ||||||||
| #' | ||||||||
| #' @param colours A character vector of colours | ||||||||
| #' @param labels Label each colour with its hex name? | ||||||||
| #' @param borders Border colour for each tile. Default uses `par("fg")`. | ||||||||
| #' Use `border = NA` to omit borders. | ||||||||
| #' @param cex_label Size of printed labels, as multiplier of default size. | ||||||||
| #' @param ncol Number of columns. If not supplied, tries to be as square as | ||||||||
| #' possible. | ||||||||
| #' @export | ||||||||
| #' @importFrom graphics par plot rect text | ||||||||
| #' @keywords internal | ||||||||
| #' @examples | ||||||||
| #' show_col(hue_pal()(9)) | ||||||||
| #' show_col(hue_pal()(9), borders = NA) | ||||||||
| #' | ||||||||
| #' show_col(viridis_pal()(16)) | ||||||||
| #' show_col(viridis_pal()(16), labels = FALSE) | ||||||||
| show_col <- function(colours, labels = TRUE, borders = NULL, cex_label = 1, | ||||||||
| ncol = NULL) { | ||||||||
| n <- length(colours) | ||||||||
| ncol <- ncol %||% ceiling(sqrt(length(colours))) | ||||||||
| nrow <- ceiling(n / ncol) | ||||||||
| colours <- c(colours, rep(NA, nrow * ncol - length(colours))) | ||||||||
| colours <- matrix(colours, ncol = ncol, byrow = TRUE) | ||||||||
| old <- par(pty = "s", mar = c(0, 0, 0, 0)) | ||||||||
| on.exit(par(old)) | ||||||||
| size <- max(dim(colours)) | ||||||||
| plot(c(0, size), c(0, -size), type = "n", xlab = "", ylab = "", axes = FALSE) | ||||||||
| rect(col(colours) - 1, -row(colours) + 1, col(colours), -row(colours), | ||||||||
| col = colours, border = borders | ||||||||
| ) | ||||||||
| if (labels) { | ||||||||
| hcl <- farver::decode_colour(colours, "rgb", "hcl") | ||||||||
| label_col <- ifelse(hcl[, "l"] > 50, "black", "white") | ||||||||
| text(col(colours) - 0.5, -row(colours) + 0.5, colours, cex = cex_label, col = label_col) | ||||||||
| } | ||||||||
| } | ||||||||
| 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. | ||||||||
| #' @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", "")) | ||||||||
| } else { | ||||||||
| "" | ||||||||
| } | ||||||||
| abort(glue("Can't find shape name:", collapsed_names, more_problems)) | ||||||||
| } | ||||||||
| 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", "")) | ||||||||
| } else { | ||||||||
| "" | ||||||||
| } | ||||||||
| abort(glue("Shape names must be unambiguous:", collapsed_names, more_problems)) | ||||||||
| } | ||||||||
| 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 { | ||||||||
| abort("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 { | ||||||||
| abort("Unknown input") | ||||||||
| } | ||||||||
| } | ||||||||
| 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) | ||||||||
| lapply(split(data, data$PANEL), function(data) { | ||||||||
| if (empty(data)) return(zeroGrob()) | ||||||||
| panel_params <- layout$panel_params[[data$PANEL[1]]] | ||||||||
| do.call(self$draw_panel, args) | ||||||||
| }) | ||||||||
| }, | ||||||||
| 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) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| setup_params = function(data, params) params, | ||||||||
| setup_data = function(data, params) data, | ||||||||
| # Combine data with defaults and set aesthetics from parameters | ||||||||
| use_defaults = function(self, data, params = list(), modifiers = aes()) { | ||||||||
| # Fill in missing aesthetics with their defaults | ||||||||
| missing_aes <- setdiff(names(self$default_aes), names(data)) | ||||||||
| missing_eval <- lapply(self$default_aes[missing_aes], 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 | ||||||||
| } | ||||||||
| # If any after_scale mappings are detected they will be resolved here | ||||||||
| # This order means that they will have access to all default aesthetics | ||||||||
| if (length(modifiers) != 0) { | ||||||||
| # Set up evaluation environment | ||||||||
| env <- child_env(baseenv(), after_scale = after_scale) | ||||||||
| # Mask stage with stage_scaled so it returns the correct expression | ||||||||
| stage_mask <- child_env(emptyenv(), stage = stage_scaled) | ||||||||
| mask <- new_data_mask(as_environment(data, stage_mask), stage_mask) | ||||||||
| mask$.data <- as_data_pronoun(mask) | ||||||||
| modified_aes <- lapply(substitute_aes(modifiers), eval_tidy, mask, env) | ||||||||
| # Check that all output are valid data | ||||||||
| nondata_modified <- check_nondata_cols(modified_aes) | ||||||||
| if (length(nondata_modified) > 0) { | ||||||||
| msg <- glue( | ||||||||
| "Modifiers must return valid values. Problematic aesthetic(s): ", | ||||||||
| glue_collapse(vapply(nondata_modified, function(x) glue("{x} = {as_label(modifiers[[x]])}"), character(1)), ", ", last = " and "), | ||||||||
| ". \nDid you map your mod in the wrong layer?" | ||||||||
| ) | ||||||||
| abort(msg) | ||||||||
| } | ||||||||
| names(modified_aes) <- rename_aes(names(modifiers)) | ||||||||
| modified_aes <- new_data_frame(compact(modified_aes)) | ||||||||
| data <- cunion(modified_aes, data) | ||||||||
| } | ||||||||
| # 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) { | ||||||||
| if (is.null(self$required_aes)) { | ||||||||
| required_aes <- NULL | ||||||||
| } else { | ||||||||
| required_aes <- unlist(strsplit(self$required_aes, '|', fixed = TRUE)) | ||||||||
| } | ||||||||
| c(union(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() | ||||||||
| } | ||||||||
| abort(glue( | ||||||||
| "Aesthetics must be either length 1 or the same as the data ({n}): ", | ||||||||
| glue_collapse(names(which(!good)), ", ", last = " and ") | ||||||||
| )) | ||||||||
| } | ||||||||
| ggplot2/R/guides-axis.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Axis guide | ||||||||
| #' | ||||||||
| #' Axis guides are the visual representation of position scales like those | ||||||||
| #' created with [scale_(x|y)_continuous()][scale_x_continuous()] and | ||||||||
| #' [scale_(x|y)_discrete()][scale_x_discrete()]. | ||||||||
| #' | ||||||||
| #' @inheritParams guide_legend | ||||||||
| #' @param check.overlap silently remove overlapping labels, | ||||||||
| #' (recursively) prioritizing the first, last, and middle labels. | ||||||||
| #' @param angle Compared to setting the angle in [theme()] / [element_text()], | ||||||||
| #' this also uses some heuristics to automatically pick the `hjust` and `vjust` that | ||||||||
| #' you probably want. | ||||||||
| #' @param n.dodge The number of rows (for vertical axes) or columns (for | ||||||||
| #' horizontal axes) that should be used to render the labels. This is | ||||||||
| #' useful for displaying labels that would otherwise overlap. | ||||||||
| #' @param order Used to determine the order of the guides (left-to-right, | ||||||||
| #' top-to-bottom), if more than one guide must be drawn at the same location. | ||||||||
| #' @param position Where this guide should be drawn: one of top, bottom, | ||||||||
| #' left, or right. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # plot with overlapping text | ||||||||
| #' p <- ggplot(mpg, aes(cty * 100, hwy * 100)) + | ||||||||
| #' geom_point() + | ||||||||
| #' facet_wrap(vars(class)) | ||||||||
| #' | ||||||||
| #' # axis guides can be customized in the scale_* functions or | ||||||||
| #' # using guides() | ||||||||
| #' p + scale_x_continuous(guide = guide_axis(n.dodge = 2)) | ||||||||
| #' p + guides(x = guide_axis(angle = 90)) | ||||||||
| #' | ||||||||
| #' # can also be used to add a duplicate guide | ||||||||
| #' p + guides(x = guide_axis(n.dodge = 2), y.sec = guide_axis()) | ||||||||
| #' | ||||||||
| #' | ||||||||
| guide_axis <- function(title = waiver(), check.overlap = FALSE, angle = NULL, n.dodge = 1, | ||||||||
| order = 0, position = waiver()) { | ||||||||
| structure( | ||||||||
| list( | ||||||||
| title = title, | ||||||||
| # customizations | ||||||||
| check.overlap = check.overlap, | ||||||||
| angle = angle, | ||||||||
| n.dodge = n.dodge, | ||||||||
| # general | ||||||||
| order = order, | ||||||||
| position = position, | ||||||||
| # parameter | ||||||||
| available_aes = c("x", "y"), | ||||||||
| name = "axis" | ||||||||
| ), | ||||||||
| class = c("guide", "axis") | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| guide_train.axis <- function(guide, scale, aesthetic = NULL) { | ||||||||
| aesthetic <- aesthetic %||% scale$aesthetics[1] | ||||||||
| breaks <- scale$get_breaks() | ||||||||
| empty_ticks <- new_data_frame( | ||||||||
| list(aesthetic = numeric(0), .value = numeric(0), .label = character(0)) | ||||||||
| ) | ||||||||
| names(empty_ticks) <- c(aesthetic, ".value", ".label") | ||||||||
| if (length(intersect(scale$aesthetics, guide$available_aes)) == 0) { | ||||||||
| warn(glue( | ||||||||
| "axis guide needs appropriate scales: ", | ||||||||
| glue_collapse(guide$available_aes, ", ", last = " or ") | ||||||||
| )) | ||||||||
| guide$key <- empty_ticks | ||||||||
| } else if (length(breaks) == 0) { | ||||||||
| guide$key <- empty_ticks | ||||||||
| } else { | ||||||||
| mapped_breaks <- if (scale$is_discrete()) scale$map(breaks) else breaks | ||||||||
| ticks <- new_data_frame(setNames(list(mapped_breaks), aesthetic)) | ||||||||
| ticks$.value <- breaks | ||||||||
| ticks$.label <- scale$get_labels(breaks) | ||||||||
| guide$key <- ticks[is.finite(ticks[[aesthetic]]), ] | ||||||||
| } | ||||||||
| guide$name <- paste0(guide$name, "_", aesthetic) | ||||||||
| guide$hash <- digest::digest(list(guide$title, guide$key$.value, guide$key$.label, guide$name)) | ||||||||
| guide | ||||||||
| } | ||||||||
| #' @export | ||||||||
| guide_transform.axis <- function(guide, coord, panel_params) { | ||||||||
| if (is.null(guide$position) || nrow(guide$key) == 0) { | ||||||||
| return(guide) | ||||||||
| } | ||||||||
| aesthetics <- names(guide$key)[!grepl("^\\.", names(guide$key))] | ||||||||
| if (all(c("x", "y") %in% aesthetics)) { | ||||||||
| guide$key <- coord$transform(guide$key, panel_params) | ||||||||
| } else { | ||||||||
| other_aesthetic <- setdiff(c("x", "y"), aesthetics) | ||||||||
| override_value <- if (guide$position %in% c("bottom", "left")) -Inf else Inf | ||||||||
| guide$key[[other_aesthetic]] <- override_value | ||||||||
| guide$key <- coord$transform(guide$key, panel_params) | ||||||||
| warn_for_guide_position(guide) | ||||||||
| } | ||||||||
| guide | ||||||||
| } | ||||||||
| # discards the new guide with a warning | ||||||||
| #' @export | ||||||||
| guide_merge.axis <- function(guide, new_guide) { | ||||||||
| if (!inherits(new_guide, "guide_none")) { | ||||||||
| warn("guide_axis(): Discarding guide on merge. Do you have more than one guide with the same position?") | ||||||||
| } | ||||||||
| guide | ||||||||
| } | ||||||||
| # axis guides don't care which geometry uses these aesthetics | ||||||||
| #' @export | ||||||||
| guide_geom.axis <- function(guide, layers, default_mapping) { | ||||||||
| guide | ||||||||
| } | ||||||||
| #' @export | ||||||||
| guide_gengrob.axis <- function(guide, theme) { | ||||||||
| aesthetic <- names(guide$key)[!grepl("^\\.", names(guide$key))][1] | ||||||||
| draw_axis( | ||||||||
| break_positions = guide$key[[aesthetic]], | ||||||||
| break_labels = guide$key$.label, | ||||||||
| axis_position = guide$position, | ||||||||
| theme = theme, | ||||||||
| check.overlap = guide$check.overlap, | ||||||||
| angle = guide$angle, | ||||||||
| n.dodge = guide$n.dodge | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Grob for axes | ||||||||
| #' | ||||||||
| #' @param break_position position of ticks | ||||||||
| #' @param break_labels labels at ticks | ||||||||
| #' @param axis_position position of axis (top, bottom, left or right) | ||||||||
| #' @param theme A complete [theme()] object | ||||||||
| #' @param check.overlap silently remove overlapping labels, | ||||||||
| #' (recursively) prioritizing the first, last, and middle labels. | ||||||||
| #' @param angle Compared to setting the angle in [theme()] / [element_text()], | ||||||||
| #' this also uses some heuristics to automatically pick the `hjust` and `vjust` that | ||||||||
| #' you probably want. | ||||||||
| #' @param n.dodge The number of rows (for vertical axes) or columns (for | ||||||||
| #' horizontal axes) that should be used to render the labels. This is | ||||||||
| #' useful for displaying labels that would otherwise overlap. | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| #' | ||||||||
| draw_axis <- function(break_positions, break_labels, axis_position, theme, | ||||||||
| check.overlap = FALSE, angle = NULL, n.dodge = 1) { | ||||||||
| axis_position <- match.arg(axis_position, c("top", "bottom", "right", "left")) | ||||||||
| aesthetic <- if (axis_position %in% c("top", "bottom")) "x" else "y" | ||||||||
| # resolve elements | ||||||||
| line_element_name <- paste0("axis.line.", aesthetic, ".", axis_position) | ||||||||
| tick_element_name <- paste0("axis.ticks.", aesthetic, ".", axis_position) | ||||||||
| tick_length_element_name <- paste0("axis.ticks.length.", aesthetic, ".", axis_position) | ||||||||
| label_element_name <- paste0("axis.text.", aesthetic, ".", axis_position) | ||||||||
| line_element <- calc_element(line_element_name, theme) | ||||||||
| tick_element <- calc_element(tick_element_name, theme) | ||||||||
| tick_length <- calc_element(tick_length_element_name, theme) | ||||||||
| label_element <- calc_element(label_element_name, theme) | ||||||||
| # override label element parameters for rotation | ||||||||
| if (inherits(label_element, "element_text")) { | ||||||||
| label_overrides <- axis_label_element_overrides(axis_position, angle) | ||||||||
| # label_overrides is an element_text, but label_element may not be; | ||||||||
| # to merge the two elements, we just copy angle, hjust, and vjust | ||||||||
| # unless their values are NULL | ||||||||
| if (!is.null(label_overrides$angle)) { | ||||||||
| label_element$angle <- label_overrides$angle | ||||||||
| } | ||||||||
| if (!is.null(label_overrides$hjust)) { | ||||||||
| label_element$hjust <- label_overrides$hjust | ||||||||
| } | ||||||||
| if (!is.null(label_overrides$vjust)) { | ||||||||
| label_element$vjust <- label_overrides$vjust | ||||||||
| } | ||||||||
| } | ||||||||
| # conditionally set parameters that depend on axis orientation | ||||||||
| is_vertical <- axis_position %in% c("left", "right") | ||||||||
| position_dim <- if (is_vertical) "y" else "x" | ||||||||
| non_position_dim <- if (is_vertical) "x" else "y" | ||||||||
| position_size <- if (is_vertical) "height" else "width" | ||||||||
| non_position_size <- if (is_vertical) "width" else "height" | ||||||||
| gtable_element <- if (is_vertical) gtable_row else gtable_col | ||||||||
| measure_gtable <- if (is_vertical) gtable_width else gtable_height | ||||||||
| measure_labels_non_pos <- if (is_vertical) grobWidth else grobHeight | ||||||||
| # conditionally set parameters that depend on which side of the panel | ||||||||
| # the axis is on | ||||||||
| is_second <- axis_position %in% c("right", "top") | ||||||||
| tick_direction <- if (is_second) 1 else -1 | ||||||||
| non_position_panel <- if (is_second) unit(0, "npc") else unit(1, "npc") | ||||||||
| tick_coordinate_order <- if (is_second) c(2, 1) else c(1, 2) | ||||||||
| # conditionally set the gtable ordering | ||||||||
| labels_first_gtable <- axis_position %in% c("left", "top") # refers to position in gtable | ||||||||
| # set common parameters | ||||||||
| n_breaks <- length(break_positions) | ||||||||
| opposite_positions <- c("top" = "bottom", "bottom" = "top", "right" = "left", "left" = "right") | ||||||||
| axis_position_opposite <- unname(opposite_positions[axis_position]) | ||||||||
| # draw elements | ||||||||
| line_grob <- exec( | ||||||||
| element_grob, line_element, | ||||||||
| !!position_dim := unit(c(0, 1), "npc"), | ||||||||
| !!non_position_dim := unit.c(non_position_panel, non_position_panel) | ||||||||
| ) | ||||||||
| if (n_breaks == 0) { | ||||||||
| return( | ||||||||
| absoluteGrob( | ||||||||
| gList(line_grob), | ||||||||
| width = grobWidth(line_grob), | ||||||||
| height = grobHeight(line_grob) | ||||||||
| ) | ||||||||
| ) | ||||||||
| } | ||||||||
| # break_labels can be a list() of language objects | ||||||||
| if (is.list(break_labels)) { | ||||||||
| if (any(vapply(break_labels, is.language, logical(1)))) { | ||||||||
| break_labels <- do.call(expression, break_labels) | ||||||||
| } else { | ||||||||
| break_labels <- unlist(break_labels) | ||||||||
| } | ||||||||
| } | ||||||||
| # calculate multiple rows/columns of labels (which is usually 1) | ||||||||
| dodge_pos <- rep(seq_len(n.dodge), length.out = n_breaks) | ||||||||
| dodge_indices <- split(seq_len(n_breaks), dodge_pos) | ||||||||
| label_grobs <- lapply(dodge_indices, function(indices) { | ||||||||
| draw_axis_labels( | ||||||||
| break_positions = break_positions[indices], | ||||||||
| break_labels = break_labels[indices], | ||||||||
| label_element = label_element, | ||||||||
| is_vertical = is_vertical, | ||||||||
| check.overlap = check.overlap | ||||||||
| ) | ||||||||
| }) | ||||||||
| ticks_grob <- exec( | ||||||||
| element_grob, tick_element, | ||||||||
| !!position_dim := rep(unit(break_positions, "native"), each = 2), | ||||||||
| !!non_position_dim := rep( | ||||||||
| unit.c(non_position_panel + (tick_direction * tick_length), non_position_panel)[tick_coordinate_order], | ||||||||
| times = n_breaks | ||||||||
| ), | ||||||||
| id.lengths = rep(2, times = n_breaks) | ||||||||
| ) | ||||||||
| # create gtable | ||||||||
| non_position_sizes <- paste0(non_position_size, "s") | ||||||||
| label_dims <- do.call(unit.c, lapply(label_grobs, measure_labels_non_pos)) | ||||||||
| grobs <- c(list(ticks_grob), label_grobs) | ||||||||
| grob_dims <- unit.c(tick_length, label_dims) | ||||||||
| if (labels_first_gtable) { | ||||||||
| grobs <- rev(grobs) | ||||||||
| grob_dims <- rev(grob_dims) | ||||||||
| } | ||||||||
| gt <- exec( | ||||||||
| gtable_element, | ||||||||
| name = "axis", | ||||||||
| grobs = grobs, | ||||||||
| !!non_position_sizes := grob_dims, | ||||||||
| !!position_size := unit(1, "npc") | ||||||||
| ) | ||||||||
| # create viewport | ||||||||
| justvp <- exec( | ||||||||
| viewport, | ||||||||
| !!non_position_dim := non_position_panel, | ||||||||
| !!non_position_size := measure_gtable(gt), | ||||||||
| just = axis_position_opposite | ||||||||
| ) | ||||||||
| absoluteGrob( | ||||||||
| gList(line_grob, gt), | ||||||||
| width = gtable_width(gt), | ||||||||
| height = gtable_height(gt), | ||||||||
| vp = justvp | ||||||||
| ) | ||||||||
| } | ||||||||
| draw_axis_labels <- function(break_positions, break_labels, label_element, is_vertical, | ||||||||
| check.overlap = FALSE) { | ||||||||
| position_dim <- if (is_vertical) "y" else "x" | ||||||||
| label_margin_name <- if (is_vertical) "margin_x" else "margin_y" | ||||||||
| n_breaks <- length(break_positions) | ||||||||
| break_positions <- unit(break_positions, "native") | ||||||||
| if (check.overlap) { | ||||||||
| priority <- axis_label_priority(n_breaks) | ||||||||
| break_labels <- break_labels[priority] | ||||||||
| break_positions <- break_positions[priority] | ||||||||
| } | ||||||||
| labels_grob <- exec( | ||||||||
| element_grob, label_element, | ||||||||
| !!position_dim := break_positions, | ||||||||
| !!label_margin_name := TRUE, | ||||||||
| label = break_labels, | ||||||||
| check.overlap = check.overlap | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Determine the label priority for a given number of labels | ||||||||
| #' | ||||||||
| #' @param n The number of labels | ||||||||
| #' | ||||||||
| #' @return The vector `seq_len(n)` arranged such that the | ||||||||
| #' first, last, and middle elements are recursively | ||||||||
| #' placed at the beginning of the vector. | ||||||||
| #' @noRd | ||||||||
| #' | ||||||||
| axis_label_priority <- function(n) { | ||||||||
| if (n <= 0) { | ||||||||
| return(numeric(0)) | ||||||||
| } | ||||||||
| c(1, n, axis_label_priority_between(1, n)) | ||||||||
| } | ||||||||
| axis_label_priority_between <- function(x, y) { | ||||||||
| n <- y - x + 1 | ||||||||
| if (n <= 2) { | ||||||||
| return(numeric(0)) | ||||||||
| } | ||||||||
| mid <- x - 1 + (n + 1) %/% 2 | ||||||||
| c( | ||||||||
| mid, | ||||||||
| axis_label_priority_between(x, mid), | ||||||||
| axis_label_priority_between(mid, y) | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Override axis text angle and alignment | ||||||||
| #' | ||||||||
| #' @param axis_position One of bottom, left, top, or right | ||||||||
| #' @param angle The text angle, or NULL to override nothing | ||||||||
| #' | ||||||||
| #' @return An [element_text()] that contains parameters that should be | ||||||||
| #' overridden from the user- or theme-supplied element. | ||||||||
| #' @noRd | ||||||||
| #' | ||||||||
| axis_label_element_overrides <- function(axis_position, angle = NULL) { | ||||||||
| if (is.null(angle)) { | ||||||||
| return(element_text(angle = NULL, hjust = NULL, vjust = NULL)) | ||||||||
| } | ||||||||
| # it is not worth the effort to align upside-down labels properly | ||||||||
| if (angle > 90 || angle < -90) { | ||||||||
| abort("`angle` must be between 90 and -90") | ||||||||
| } | ||||||||
| if (axis_position == "bottom") { | ||||||||
| element_text( | ||||||||
| angle = angle, | ||||||||
| hjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5, | ||||||||
| vjust = if (abs(angle) == 90) 0.5 else 1 | ||||||||
| ) | ||||||||
| } else if (axis_position == "left") { | ||||||||
| element_text( | ||||||||
| angle = angle, | ||||||||
| hjust = if (abs(angle) == 90) 0.5 else 1, | ||||||||
| vjust = if (angle > 0) 0 else if (angle < 0) 1 else 0.5, | ||||||||
| ) | ||||||||
| } else if (axis_position == "top") { | ||||||||
| element_text( | ||||||||
| angle = angle, | ||||||||
| hjust = if (angle > 0) 0 else if (angle < 0) 1 else 0.5, | ||||||||
| vjust = if (abs(angle) == 90) 0.5 else 0 | ||||||||
| ) | ||||||||
| } else if (axis_position == "right") { | ||||||||
| element_text( | ||||||||
| angle = angle, | ||||||||
| hjust = if (abs(angle) == 90) 0.5 else 0, | ||||||||
| vjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5, | ||||||||
| ) | ||||||||
| } else { | ||||||||
| abort(glue("Unrecognized position: '{axis_position}'")) | ||||||||
| } | ||||||||
| } | ||||||||
| warn_for_guide_position <- function(guide) { | ||||||||
| if (empty(guide$key) || nrow(guide$key) == 1) { | ||||||||
| return() | ||||||||
| } | ||||||||
| # this is trying to catch when a user specifies a position perpendicular | ||||||||
| # to the direction of the axis (e.g., a "y" axis on "top") | ||||||||
| if (guide$position %in% c("top", "bottom")) { | ||||||||
| position_aes <- "x" | ||||||||
| } else if(guide$position %in% c("left", "right")) { | ||||||||
| position_aes <- "y" | ||||||||
| } else { | ||||||||
| return() | ||||||||
| } | ||||||||
| if (length(unique(guide$key[[position_aes]])) == 1) { | ||||||||
| warn("Position guide is perpendicular to the intended axis. Did you mean to specify a different guide `position`?") | ||||||||
| } | ||||||||
| } | ||||||||
| ggplot2/R/guides-.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Set guides for each scale | ||||||||
| #' | ||||||||
| #' Guides for each scale can be set scale-by-scale with the `guide` | ||||||||
| #' argument, or en masse with `guides()`. | ||||||||
| #' | ||||||||
| #' @param ... List of scale name-guide pairs. The guide can either | ||||||||
| #' be a string (i.e. "colorbar" or "legend"), or a call to a guide function | ||||||||
| #' (i.e. [guide_colourbar()] or [guide_legend()]) | ||||||||
| #' specifying additional arguments. | ||||||||
| #' @return A list containing the mapping between scale and guide. | ||||||||
| #' @export | ||||||||
| #' @family guides | ||||||||
| #' @examples | ||||||||
| #' \donttest{ | ||||||||
| #' # ggplot object | ||||||||
| #' | ||||||||
| #' dat <- data.frame(x = 1:5, y = 1:5, p = 1:5, q = factor(1:5), | ||||||||
| #' r = factor(1:5)) | ||||||||
| #' p <- ggplot(dat, aes(x, y, colour = p, size = q, shape = r)) + geom_point() | ||||||||
| #' | ||||||||
| #' # without guide specification | ||||||||
| #' p | ||||||||
| #' | ||||||||
| #' # Show colorbar guide for colour. | ||||||||
| #' # All these examples below have a same effect. | ||||||||
| #' | ||||||||
| #' p + guides(colour = "colorbar", size = "legend", shape = "legend") | ||||||||
| #' p + guides(colour = guide_colorbar(), size = guide_legend(), | ||||||||
| #' shape = guide_legend()) | ||||||||
| #' p + | ||||||||
| #' scale_colour_continuous(guide = "colorbar") + | ||||||||
| #' scale_size_discrete(guide = "legend") + | ||||||||
| #' scale_shape(guide = "legend") | ||||||||
| #' | ||||||||
| #' # Remove some guides | ||||||||
| #' p + guides(colour = "none") | ||||||||
| #' p + guides(colour = "colorbar",size = "none") | ||||||||
| #' | ||||||||
| #' # Guides are integrated where possible | ||||||||
| #' | ||||||||
| #' p + guides(colour = guide_legend("title"), size = guide_legend("title"), | ||||||||
| #' shape = guide_legend("title")) | ||||||||
| #' # same as | ||||||||
| #' g <- guide_legend("title") | ||||||||
| #' p + guides(colour = g, size = g, shape = g) | ||||||||
| #' | ||||||||
| #' p + theme(legend.position = "bottom") | ||||||||
| #' | ||||||||
| #' # position of guides | ||||||||
| #' | ||||||||
| #' # Set order for multiple guides | ||||||||
| #' ggplot(mpg, aes(displ, cty)) + | ||||||||
| #' geom_point(aes(size = hwy, colour = cyl, shape = drv)) + | ||||||||
| #' guides( | ||||||||
| #' colour = guide_colourbar(order = 1), | ||||||||
| #' shape = guide_legend(order = 2), | ||||||||
| #' size = guide_legend(order = 3) | ||||||||
| #' ) | ||||||||
| #' } | ||||||||
| guides <- function(...) { | ||||||||
| args <- list(...) | ||||||||
| if (length(args) > 0) { | ||||||||
| if (is.list(args[[1]]) && !inherits(args[[1]], "guide")) args <- args[[1]] | ||||||||
| args <- rename_aes(args) | ||||||||
| } | ||||||||
| structure(args, class = "guides") | ||||||||
| } | ||||||||
| update_guides <- function(p, guides) { | ||||||||
| p <- plot_clone(p) | ||||||||
| p$guides <- defaults(guides, p$guides) | ||||||||
| p | ||||||||
| } | ||||||||
| # building non-position guides - called in ggplotGrob (plot-build.r) | ||||||||
| # | ||||||||
| # the procedure is as follows: | ||||||||
| # | ||||||||
| # 1. guides_train() | ||||||||
| # train each scale and generate guide definition for all guides | ||||||||
| # here, one gdef for one scale | ||||||||
| # | ||||||||
| # 2. guides_merge() | ||||||||
| # merge gdefs if they are overlayed | ||||||||
| # number of gdefs may be less than number of scales | ||||||||
| # | ||||||||
| # 3. guides_geom() | ||||||||
| # process layer information and generate geom info. | ||||||||
| # | ||||||||
| # 4. guides_gengrob() | ||||||||
| # generate ggrob from each gdef | ||||||||
| # one ggrob for one gdef | ||||||||
| # | ||||||||
| # 5. guides_build() | ||||||||
| # arrange all ggrobs | ||||||||
| build_guides <- function(scales, layers, default_mapping, position, theme, guides, labels) { | ||||||||
| theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size | ||||||||
| theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size | ||||||||
| # Layout of legends depends on their overall location | ||||||||
| position <- legend_position(position) | ||||||||
| if (position == "inside") { | ||||||||
| theme$legend.box <- theme$legend.box %||% "vertical" | ||||||||
| theme$legend.direction <- theme$legend.direction %||% "vertical" | ||||||||
| theme$legend.box.just <- theme$legend.box.just %||% c("center", "center") | ||||||||
| } else if (position == "vertical") { | ||||||||
| theme$legend.box <- theme$legend.box %||% "vertical" | ||||||||
| theme$legend.direction <- theme$legend.direction %||% "vertical" | ||||||||
| theme$legend.box.just <- theme$legend.box.just %||% c("left", "top") | ||||||||
| } else if (position == "horizontal") { | ||||||||
| theme$legend.box <- theme$legend.box %||% "horizontal" | ||||||||
| theme$legend.direction <- theme$legend.direction %||% "horizontal" | ||||||||
| theme$legend.box.just <- theme$legend.box.just %||% c("center", "top") | ||||||||
| } | ||||||||
| # scales -> data for guides | ||||||||
| gdefs <- guides_train( | ||||||||
| scales = scales$non_position_scales(), | ||||||||
| theme = theme, | ||||||||
| guides = guides, | ||||||||
| labels = labels | ||||||||
| ) | ||||||||
| if (length(gdefs) == 0) return(zeroGrob()) | ||||||||
| # merge overlay guides | ||||||||
| gdefs <- guides_merge(gdefs) | ||||||||
| # process layer information | ||||||||
| gdefs <- guides_geom(gdefs, layers, default_mapping) | ||||||||
| if (length(gdefs) == 0) return(zeroGrob()) | ||||||||
| # generate grob of each guides | ||||||||
| ggrobs <- guides_gengrob(gdefs, theme) | ||||||||
| # build up guides | ||||||||
| grobs <- guides_build(ggrobs, theme) | ||||||||
| grobs | ||||||||
| } | ||||||||
| # Simplify legend position to one of horizontal/vertical/inside | ||||||||
| legend_position <- function(position) { | ||||||||
| if (length(position) == 1) { | ||||||||
| if (position %in% c("top", "bottom")) { | ||||||||
| "horizontal" | ||||||||
| } else { | ||||||||
| "vertical" | ||||||||
| } | ||||||||
| } else { | ||||||||
| "inside" | ||||||||
| } | ||||||||
| } | ||||||||
| # resolve the guide from the scale and guides | ||||||||
| resolve_guide <- function(aesthetic, scale, guides, default = "none", null = "none") { | ||||||||
| guides[[aesthetic]] %||% scale$guide %|W|% default %||% null | ||||||||
| } | ||||||||
| # validate guide object | ||||||||
| validate_guide <- function(guide) { | ||||||||
| # if guide is specified by character, then find the corresponding guide | ||||||||
| # when guides are officially extensible, this should use find_global() | ||||||||
| if (is.character(guide)) | ||||||||
| match.fun(paste("guide_", guide, sep = ""))() | ||||||||
| else if (inherits(guide, "guide")) | ||||||||
| guide | ||||||||
| else | ||||||||
| abort(glue("Unknown guide: {guide}")) | ||||||||
| } | ||||||||
| # train each scale in scales and generate the definition of guide | ||||||||
| guides_train <- function(scales, theme, guides, labels) { | ||||||||
| gdefs <- list() | ||||||||
| for (scale in scales$scales) { | ||||||||
| for (output in scale$aesthetics) { | ||||||||
| # guides(XXX) is stored in guides[[XXX]], | ||||||||
| # which is prior to scale_ZZZ(guide=XXX) | ||||||||
| # guide is determined in order of: | ||||||||
| # + guides(XXX) > + scale_ZZZ(guide=XXX) > default(i.e., legend) | ||||||||
| guide <- resolve_guide(output, scale, guides) | ||||||||
| # this should be changed to testing guide == "none" | ||||||||
| # scale$legend is backward compatibility | ||||||||
| # if guides(XXX=FALSE), then scale_ZZZ(guides=XXX) is discarded. | ||||||||
| if (identical(guide, "none") || isFALSE(guide) || inherits(guide, "guide_none")) next | ||||||||
| # check the validity of guide. | ||||||||
| # if guide is character, then find the guide object | ||||||||
| guide <- validate_guide(guide) | ||||||||
| # check the consistency of the guide and scale. | ||||||||
| if (!identical(guide$available_aes, "any") && !any(scale$aesthetics %in% guide$available_aes)) { | ||||||||
| abort(glue("Guide '{guide$name}' cannot be used for '{scale$aesthetics}'.")) | ||||||||
| } | ||||||||
| guide$title <- scale$make_title(guide$title %|W|% scale$name %|W|% labels[[output]]) | ||||||||
| # direction of this grob | ||||||||
| guide$direction <- guide$direction %||% theme$legend.direction | ||||||||
| # each guide object trains scale within the object, | ||||||||
| # so Guides (i.e., the container of guides) need not to know about them | ||||||||
| guide <- guide_train(guide, scale, output) | ||||||||
| if (!is.null(guide)) gdefs[[length(gdefs) + 1]] <- guide | ||||||||
| } | ||||||||
| } | ||||||||
| gdefs | ||||||||
| } | ||||||||
| # merge overlapped guides | ||||||||
| guides_merge <- function(gdefs) { | ||||||||
| # split gdefs based on hash, and apply Reduce (guide_merge) to each gdef group. | ||||||||
| gdefs <- lapply(gdefs, function(g) { | ||||||||
| if (g$order == 0) { | ||||||||
| order <- "99" | ||||||||
| } else { | ||||||||
| order <- sprintf("%02d", g$order) | ||||||||
| } | ||||||||
| g$hash <- paste(order, g$hash, sep = "_") | ||||||||
| g | ||||||||
| }) | ||||||||
| tapply(gdefs, sapply(gdefs, function(g)g$hash), function(gs)Reduce(guide_merge, gs)) | ||||||||
| } | ||||||||
| # process layer information | ||||||||
| guides_geom <- function(gdefs, layers, default_mapping) { | ||||||||
| compact(lapply(gdefs, guide_geom, layers, default_mapping)) | ||||||||
| } | ||||||||
| # generate grob from each gdef (needs to write this function?) | ||||||||
| guides_gengrob <- function(gdefs, theme) { | ||||||||
| # common drawing process for all guides | ||||||||
| gdefs <- lapply(gdefs, | ||||||||
| function(g) { | ||||||||
| g$title.position <- g$title.position %||% switch(g$direction, vertical = "top", horizontal = "left") | ||||||||
| if (!g$title.position %in% c("top", "bottom", "left", "right")) { | ||||||||
| abort(glue("title position '{g$title.position}' is invalid")) | ||||||||
| } | ||||||||
| g | ||||||||
| }) | ||||||||
| lapply(gdefs, guide_gengrob, theme) | ||||||||
| } | ||||||||
| # build up all guide boxes into one guide-boxes. | ||||||||
| guides_build <- function(ggrobs, theme) { | ||||||||
| theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines") | ||||||||
| theme$legend.spacing.y <- theme$legend.spacing.y %||% theme$legend.spacing | ||||||||
| theme$legend.spacing.x <- theme$legend.spacing.x %||% theme$legend.spacing | ||||||||
| widths <- do.call("unit.c", lapply(ggrobs, function(g)sum(g$widths))) | ||||||||
| heights <- do.call("unit.c", lapply(ggrobs, function(g)sum(g$heights))) | ||||||||
| # Set the justification of each legend within the legend box | ||||||||
| # First value is xjust, second value is yjust | ||||||||
| just <- valid.just(theme$legend.box.just) | ||||||||
| xjust <- just[1] | ||||||||
| yjust <- just[2] | ||||||||
| # setting that is different for vertical and horizontal guide-boxes. | ||||||||
| if (identical(theme$legend.box, "horizontal")) { | ||||||||
| # Set justification for each legend | ||||||||
| for (i in seq_along(ggrobs)) { | ||||||||
| ggrobs[[i]] <- editGrob(ggrobs[[i]], | ||||||||
| vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust), | ||||||||
| height = heightDetails(ggrobs[[i]]))) | ||||||||
| } | ||||||||
| guides <- gtable_row(name = "guides", | ||||||||
| grobs = ggrobs, | ||||||||
| widths = widths, height = max(heights)) | ||||||||
| # add space between the guide-boxes | ||||||||
| guides <- gtable_add_col_space(guides, theme$legend.spacing.x) | ||||||||
| } else { # theme$legend.box == "vertical" | ||||||||
| # Set justification for each legend | ||||||||
| for (i in seq_along(ggrobs)) { | ||||||||
| ggrobs[[i]] <- editGrob(ggrobs[[i]], | ||||||||
| vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust), | ||||||||
| width = widthDetails(ggrobs[[i]]))) | ||||||||
| } | ||||||||
| guides <- gtable_col(name = "guides", | ||||||||
| grobs = ggrobs, | ||||||||
| width = max(widths), heights = heights) | ||||||||
| # add space between the guide-boxes | ||||||||
| guides <- gtable_add_row_space(guides, theme$legend.spacing.y) | ||||||||
| } | ||||||||
| # Add margins around the guide-boxes. | ||||||||
| theme$legend.box.margin <- theme$legend.box.margin %||% margin() | ||||||||
| guides <- gtable_add_cols(guides, theme$legend.box.margin[4], pos = 0) | ||||||||
| guides <- gtable_add_cols(guides, theme$legend.box.margin[2], pos = ncol(guides)) | ||||||||
| guides <- gtable_add_rows(guides, theme$legend.box.margin[1], pos = 0) | ||||||||
| guides <- gtable_add_rows(guides, theme$legend.box.margin[3], pos = nrow(guides)) | ||||||||
| # Add legend box background | ||||||||
| background <- element_grob(theme$legend.box.background %||% element_blank()) | ||||||||
| guides <- gtable_add_grob(guides, background, t = 1, l = 1, | ||||||||
| b = -1, r = -1, z = -Inf, clip = "off", name = "legend.box.background") | ||||||||
| guides$name <- "guide-box" | ||||||||
| guides | ||||||||
| } | ||||||||
| # Generics ---------------------------------------------------------------- | ||||||||
| #' S3 generics for guides. | ||||||||
| #' | ||||||||
| #' You will need to provide methods for these S3 generics if you want to | ||||||||
| #' create your own guide object. They are currently undocumented; use at | ||||||||
| #' your own risk! | ||||||||
| #' | ||||||||
| #' @param guide The guide object | ||||||||
| #' @keywords internal | ||||||||
| #' @name guide-exts | ||||||||
| NULL | ||||||||
| #' @export | ||||||||
| #' @rdname guide-exts | ||||||||
| guide_train <- function(guide, scale, aesthetic = NULL) UseMethod("guide_train") | ||||||||
| #' @export | ||||||||
| #' @rdname guide-exts | ||||||||
| guide_merge <- function(guide, new_guide) UseMethod("guide_merge") | ||||||||
| #' @export | ||||||||
| #' @rdname guide-exts | ||||||||
| guide_geom <- function(guide, layers, default_mapping) UseMethod("guide_geom") | ||||||||
| #' @export | ||||||||
| #' @rdname guide-exts | ||||||||
| guide_transform <- function(guide, coord, panel_params) UseMethod("guide_transform") | ||||||||
| #' @export | ||||||||
| guide_transform.default <- function(guide, coord, panel_params) { | ||||||||
| abort(glue( | ||||||||
| "Guide with class ", | ||||||||
| glue_collapse(class(guide), " / "), | ||||||||
| " does not implement guide_transform(). ", | ||||||||
| "Did you mean to use guide_axis()?" | ||||||||
| )) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname guide-exts | ||||||||
| guide_gengrob <- function(guide, theme) UseMethod("guide_gengrob") | ||||||||
| # Helpers ----------------------------------------------------------------- | ||||||||
| matched_aes <- function(layer, guide, defaults) { | ||||||||
| all <- names(c(layer$mapping, if (layer$inherit.aes) defaults, layer$stat$default_aes)) | ||||||||
| geom <- c(layer$geom$required_aes, names(layer$geom$default_aes)) | ||||||||
| matched <- intersect(intersect(all, geom), names(guide$key)) | ||||||||
| matched <- setdiff(matched, names(layer$geom_params)) | ||||||||
| setdiff(matched, names(layer$aes_params)) | ||||||||
| } | ||||||||
| # This function is used by guides in guide_geom.* to determine whether | ||||||||
| # a given layer should be included in the guide | ||||||||
| # `matched` is the set of aesthetics that match between the layer and the guide | ||||||||
| include_layer_in_guide <- function(layer, matched) { | ||||||||
| if (!is.logical(layer$show.legend)) { | ||||||||
| warn("`show.legend` must be a logical vector.") | ||||||||
| layer$show.legend <- FALSE # save back to layer so we don't issue this warning more than once | ||||||||
| return(FALSE) | ||||||||
| } | ||||||||
| if (length(matched) > 0) { | ||||||||
| # This layer contributes to the legend | ||||||||
| # check if this layer should be included, different behaviour depending on | ||||||||
| # if show.legend is a logical or a named logical vector | ||||||||
| if (is_named(layer$show.legend)) { | ||||||||
| layer$show.legend <- rename_aes(layer$show.legend) | ||||||||
| show_legend <- layer$show.legend[matched] | ||||||||
| # we cannot use `isTRUE(is.na(show_legend))` here because | ||||||||
| # 1. show_legend can be multiple NAs | ||||||||
| # 2. isTRUE() was not tolerant for a named TRUE | ||||||||
| show_legend <- show_legend[!is.na(show_legend)] | ||||||||
| return(length(show_legend) == 0 || any(show_legend)) | ||||||||
| } | ||||||||
| return(all(is.na(layer$show.legend)) || isTRUE(layer$show.legend)) | ||||||||
| } | ||||||||
| # This layer does not contribute to the legend. | ||||||||
| # Default is to exclude it, except if it is explicitly turned on | ||||||||
| isTRUE(layer$show.legend) | ||||||||
| } | ||||||||
| 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, scales)` 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) { | ||||||||
| dapply(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) { | ||||||||
| abort("Not implemented") | ||||||||
| } | ||||||||
| ) | ||||||||
| #' 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, ...) { | ||||||||
| # Treat df as list during transformation for faster set/get | ||||||||
| oldclass <- class(df) | ||||||||
| df <- unclass(df) | ||||||||
| 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, ...) | ||||||||
| } | ||||||||
| class(df) <- oldclass | ||||||||
| df | ||||||||
| } | ||||||||
| ggplot2/R/guides-grid.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| # Produce a grob to be used as for panel backgrounds | ||||||||
| # minor and major grid line positions are given as fractional positions and will | ||||||||
| # be converted to `'native'` units by polylineGrob() downstream | ||||||||
| # | ||||||||
| # Any minor lines coinciding with major lines will be removed | ||||||||
| 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/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 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, | ||||||||
| #' `margin()` 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 | ||||||||
| n <- max( | ||||||||
| length(family), length(face), length(colour), length(size), | ||||||||
| length(hjust), length(vjust), length(angle), length(lineheight) | ||||||||
| ) | ||||||||
| if (n > 1) { | ||||||||
| warn("Vectorized input to `element_text()` is not officially supported.\nResults may be unexpected or may change in future versions of ggplot2.") | ||||||||
| } | ||||||||
| 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") | ||||||||
| #' Render a specified theme element into a grob | ||||||||
| #' | ||||||||
| #' Given a theme object and element name, returns a grob for the element. | ||||||||
| #' Uses [`element_grob()`] to generate the grob. | ||||||||
| #' @param theme The theme object | ||||||||
| #' @param element The element name given as character vector | ||||||||
| #' @param ... Other arguments provided to [`element_grob()`] | ||||||||
| #' @param name Character vector added to the name of the grob | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| 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( | ||||||||
| col = colour, fill = colour, | ||||||||
| lwd = len0_null(size * .pt), lty = linetype, lineend = lineend | ||||||||
| ) | ||||||||
| element_gp <- gpar( | ||||||||
| col = element$colour, fill = element$colour, | ||||||||
| lwd = len0_null(element$size * .pt), 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 and register new theme elements | ||||||||
| #' | ||||||||
| #' The underlying structure of a ggplot2 theme is defined via the element tree, which | ||||||||
| #' specifies for each theme element what type it should have and whether it inherits from | ||||||||
| #' a parent element. In some use cases, it may be necessary to modify or extend this | ||||||||
| #' element tree and provide default settings for newly defined theme elements. | ||||||||
| #' | ||||||||
| #' The function `register_theme_elements()` provides the option to globally register new | ||||||||
| #' theme elements with ggplot2. In general, for each new theme element both an element | ||||||||
| #' definition and a corresponding entry in the element tree should be provided. See | ||||||||
| #' examples for details. This function is meant primarily for developers of extension | ||||||||
| #' packages, who are strongly urged to adhere to the following best practices: | ||||||||
| #' | ||||||||
| #' 1. Call `register_theme_elements()` from the `.onLoad()` function of your package, so | ||||||||
| #' that the new theme elements are available to anybody using functions from your package, | ||||||||
| #' irrespective of whether the package has been attached (with `library()` or `require()`) | ||||||||
| #' or not. | ||||||||
| #' 2. For any new elements you create, prepend them with the name of your package, to avoid | ||||||||
| #' name clashes with other extension packages. For example, if you are working on a package | ||||||||
| #' **ggxyz**, and you want it to provide a new element for plot panel annotations (as demonstrated | ||||||||
| #' in the Examples below), name the new element `ggxyz.panel.annotation`. | ||||||||
| #' @param ... Element specifications | ||||||||
| #' @param element_tree Addition of or modification to the element tree, which specifies the | ||||||||
| #' inheritance relationship of the theme elements. The element tree must be provided as | ||||||||
| #' a list of named element definitions created with el_def(). | ||||||||
| #' @param complete If `TRUE` (the default), elements are set to inherit from blank elements. | ||||||||
| #' @examples | ||||||||
| #' # Let's assume a package `ggxyz` wants to provide an easy way to add annotations to | ||||||||
| #' # plot panels. To do so, it registers a new theme element `ggxyz.panel.annotation` | ||||||||
| #' register_theme_elements( | ||||||||
| #' ggxyz.panel.annotation = element_text(color = "blue", hjust = 0.95, vjust = 0.05), | ||||||||
| #' element_tree = list(ggxyz.panel.annotation = el_def("element_text", "text")) | ||||||||
| #' ) | ||||||||
| #' | ||||||||
| #' # Now the package can define a new coord that includes a panel annotation | ||||||||
| #' coord_annotate <- function(label = "panel annotation") { | ||||||||
| #' ggproto(NULL, CoordCartesian, | ||||||||
| #' limits = list(x = NULL, y = NULL), | ||||||||
| #' expand = TRUE, | ||||||||
| #' default = FALSE, | ||||||||
| #' clip = "on", | ||||||||
| #' render_fg = function(panel_params, theme) { | ||||||||
| #' element_render(theme, "ggxyz.panel.annotation", label = label) | ||||||||
| #' } | ||||||||
| #' ) | ||||||||
| #' } | ||||||||
| #' | ||||||||
| #' # Example plot with this new coord | ||||||||
| #' df <- data.frame(x = 1:3, y = 1:3) | ||||||||
| #' ggplot(df, aes(x, y)) + | ||||||||
| #' geom_point() + | ||||||||
| #' coord_annotate("annotation in blue") | ||||||||
| #' | ||||||||
| #' # Revert to the original ggplot2 settings | ||||||||
| #' reset_theme_settings() | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| register_theme_elements <- function(..., element_tree = NULL, complete = TRUE) { | ||||||||
| old <- ggplot_global$theme_default | ||||||||
| t <- theme(..., complete = complete) | ||||||||
| ggplot_global$theme_default <- ggplot_global$theme_default %+replace% t | ||||||||
| # Merge element trees | ||||||||
| ggplot_global$element_tree <- defaults(element_tree, ggplot_global$element_tree) | ||||||||
| invisible(old) | ||||||||
| } | ||||||||
| #' @rdname register_theme_elements | ||||||||
| #' @details | ||||||||
| #' The function `reset_theme_settings()` restores the default element tree, discards | ||||||||
| #' all new element definitions, and (unless turned off) resets the currently active | ||||||||
| #' theme to the default. | ||||||||
| #' @param reset_current If `TRUE` (the default), the currently active theme is | ||||||||
| #' reset to the default theme. | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| reset_theme_settings <- function(reset_current = TRUE) { | ||||||||
| ggplot_global$element_tree <- .element_tree | ||||||||
| # reset the underlying fallback default theme | ||||||||
| ggplot_global$theme_default <- theme_grey() | ||||||||
| if (isTRUE(reset_current)) { | ||||||||
| # reset the currently active theme | ||||||||
| ggplot_global$theme_current <- ggplot_global$theme_default | ||||||||
| } | ||||||||
| } | ||||||||
| #' @rdname register_theme_elements | ||||||||
| #' @details | ||||||||
| #' The function `get_element_tree()` returns the currently active element tree. | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| get_element_tree <- function() { | ||||||||
| ggplot_global$element_tree | ||||||||
| } | ||||||||
| #' @rdname register_theme_elements | ||||||||
| #' @details | ||||||||
| #' The function `el_def()` is used to define new or modified element types and | ||||||||
| #' element inheritance relationships for the element tree. | ||||||||
| #' @param class The name of the element class. Examples are "element_line" or | ||||||||
| #' "element_text" or "unit", or one of the two reserved keywords "character" or | ||||||||
| #' "margin". The reserved keyword "character" implies a character | ||||||||
| #' or numeric vector, not a class called "character". The keyword | ||||||||
| #' "margin" implies a unit vector of length 4, as created by [margin()]. | ||||||||
| #' @param inherit A vector of strings, naming the elements that this | ||||||||
| #' element inherits from. | ||||||||
| #' @param description An optional character vector providing a description | ||||||||
| #' for the element. | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| el_def <- function(class = NULL, inherit = NULL, description = NULL) { | ||||||||
| list(class = class, inherit = inherit, description = description) | ||||||||
| } | ||||||||
| # This data structure represents the default theme elements and the inheritance | ||||||||
| # among them. It should not be read from directly, since users may modify the | ||||||||
| # current element tree stored in ggplot_global$element_tree | ||||||||
| .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.length.x = el_def("unit", "axis.ticks.length"), | ||||||||
| axis.ticks.length.x.top = el_def("unit", "axis.ticks.length.x"), | ||||||||
| axis.ticks.length.x.bottom = el_def("unit", "axis.ticks.length.x"), | ||||||||
| axis.ticks.length.y = el_def("unit", "axis.ticks.length"), | ||||||||
| axis.ticks.length.y.left = el_def("unit", "axis.ticks.length.y"), | ||||||||
| axis.ticks.length.y.right = el_def("unit", "axis.ticks.length.y"), | ||||||||
| 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.x.top = el_def("element_text", "strip.text.x"), | ||||||||
| strip.text.x.bottom = el_def("element_text", "strip.text.x"), | ||||||||
| strip.text.y = el_def("element_text", "strip.text"), | ||||||||
| strip.text.y.left = el_def("element_text", "strip.text.y"), | ||||||||
| strip.text.y.right = el_def("element_text", "strip.text.y"), | ||||||||
| 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.title.position = el_def("character"), | ||||||||
| plot.subtitle = el_def("element_text", "title"), | ||||||||
| plot.caption = el_def("element_text", "title"), | ||||||||
| plot.caption.position = el_def("character"), | ||||||||
| 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") | ||||||||
| ) | ||||||||
| # 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 | ||||||||
| # @param element_tree the element tree to validate against | ||||||||
| validate_element <- function(el, elname, element_tree) { | ||||||||
| eldef <- element_tree[[elname]] | ||||||||
| if (is.null(eldef)) { | ||||||||
| abort(glue("Theme element `{elname}` is not defined in the element hierarchy.")) | ||||||||
| } | ||||||||
| # 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)) | ||||||||
| abort(glue("Theme element `{elname}` must be a string or numeric vector.")) | ||||||||
| } else if (eldef$class == "margin") { | ||||||||
| if (!is.unit(el) && length(el) == 4) | ||||||||
| abort(glue("Theme element `{elname}` must be a unit vector of length 4.")) | ||||||||
| } else if (!inherits(el, eldef$class) && !inherits(el, "element_blank")) { | ||||||||
| abort(glue("Theme element `{elname}` must be an object of type `{eldef$class}`.")) | ||||||||
| } | ||||||||
| invisible() | ||||||||
| } | ||||||||
| rlang/R/eval.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Evaluate an expression in an environment | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' \Sexpr[results=rd, stage=render]{rlang:::lifecycle("stable")} | ||||||||
| #' | ||||||||
| #' `eval_bare()` is a lower-level version of function [base::eval()]. | ||||||||
| #' Technically, it is a simple wrapper around the C function | ||||||||
| #' `Rf_eval()`. You generally don't need to use `eval_bare()` instead | ||||||||
| #' of `eval()`. Its main advantage is that it handles stack-sensitive | ||||||||
| #' (calls such as `return()`, `on.exit()` or `parent.frame()`) more | ||||||||
| #' consistently when you pass an enviroment of a frame on the call | ||||||||
| #' stack. | ||||||||
| #' | ||||||||
| #' @details | ||||||||
| #' | ||||||||
| #' These semantics are possible because `eval_bare()` creates only one | ||||||||
| #' frame on the call stack whereas `eval()` creates two frames, the | ||||||||
| #' second of which has the user-supplied environment as frame | ||||||||
| #' environment. When you supply an existing frame environment to | ||||||||
| #' `base::eval()` there will be two frames on the stack with the same | ||||||||
| #' frame environment. Stack-sensitive functions only detect the | ||||||||
| #' topmost of these frames. We call these evaluation semantics | ||||||||
| #' "stack inconsistent". | ||||||||
| #' | ||||||||
| #' Evaluating expressions in the actual frame environment has useful | ||||||||
| #' practical implications for `eval_bare()`: | ||||||||
| #' | ||||||||
| #' * `return()` calls are evaluated in frame environments that might | ||||||||
| #' be burried deep in the call stack. This causes a long return that | ||||||||
| #' unwinds multiple frames (triggering the `on.exit()` event for | ||||||||
| #' each frame). By contrast `eval()` only returns from the `eval()` | ||||||||
| #' call, one level up. | ||||||||
| #' | ||||||||
| #' * `on.exit()`, `parent.frame()`, `sys.call()`, and generally all | ||||||||
| #' the stack inspection functions `sys.xxx()` are evaluated in the | ||||||||
| #' correct frame environment. This is similar to how this type of | ||||||||
| #' calls can be evaluated deep in the call stack because of lazy | ||||||||
| #' evaluation, when you force an argument that has been passed | ||||||||
| #' around several times. | ||||||||
| #' | ||||||||
| #' The flip side of the semantics of `eval_bare()` is that it can't | ||||||||
| #' evaluate `break` or `next` expressions even if called within a | ||||||||
| #' loop. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @param expr An expression to evaluate. | ||||||||
| #' @param env The environment in which to evaluate the expression. | ||||||||
| #' | ||||||||
| #' @seealso [eval_tidy()] for evaluation with data mask and quosure | ||||||||
| #' support. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # eval_bare() works just like base::eval() but you have to create | ||||||||
| #' # the evaluation environment yourself: | ||||||||
| #' eval_bare(quote(foo), env(foo = "bar")) | ||||||||
| #' | ||||||||
| #' # eval() has different evaluation semantics than eval_bare(). It | ||||||||
| #' # can return from the supplied environment even if its an | ||||||||
| #' # environment that is not on the call stack (i.e. because you've | ||||||||
| #' # created it yourself). The following would trigger an error with | ||||||||
| #' # eval_bare(): | ||||||||
| #' ret <- quote(return("foo")) | ||||||||
| #' eval(ret, env()) | ||||||||
| #' # eval_bare(ret, env()) # "no function to return from" error | ||||||||
| #' | ||||||||
| #' # Another feature of eval() is that you can control surround loops: | ||||||||
| #' bail <- quote(break) | ||||||||
| #' while (TRUE) { | ||||||||
| #' eval(bail) | ||||||||
| #' # eval_bare(bail) # "no loop for break/next" error | ||||||||
| #' } | ||||||||
| #' | ||||||||
| #' # To explore the consequences of stack inconsistent semantics, let's | ||||||||
| #' # create a function that evaluates `parent.frame()` deep in the call | ||||||||
| #' # stack, in an environment corresponding to a frame in the middle of | ||||||||
| #' # the stack. For consistency with R's lazy evaluation semantics, we'd | ||||||||
| #' # expect to get the caller of that frame as result: | ||||||||
| #' fn <- function(eval_fn) { | ||||||||
| #' list( | ||||||||
| #' returned_env = middle(eval_fn), | ||||||||
| #' actual_env = current_env() | ||||||||
| #' ) | ||||||||
| #' } | ||||||||
| #' middle <- function(eval_fn) { | ||||||||
| #' deep(eval_fn, current_env()) | ||||||||
| #' } | ||||||||
| #' deep <- function(eval_fn, eval_env) { | ||||||||
| #' expr <- quote(parent.frame()) | ||||||||
| #' eval_fn(expr, eval_env) | ||||||||
| #' } | ||||||||
| #' | ||||||||
| #' # With eval_bare(), we do get the expected environment: | ||||||||
| #' fn(rlang::eval_bare) | ||||||||
| #' | ||||||||
| #' # But that's not the case with base::eval(): | ||||||||
| #' fn(base::eval) | ||||||||
| eval_bare <- function(expr, env = parent.frame()) { | ||||||||
| .External2(rlang_ext2_eval, expr, env) | ||||||||
| } | ||||||||
| #' Evaluate an expression within a given environment | ||||||||
| #' | ||||||||
| #' These functions evaluate `expr` within a given environment (`env` | ||||||||
| #' for `with_env()`, or the child of the current environment for | ||||||||
| #' `locally`). They rely on [eval_bare()] which features a lighter | ||||||||
| #' evaluation mechanism than base R [base::eval()], and which also has | ||||||||
| #' some subtle implications when evaluting stack sensitive functions | ||||||||
| #' (see help for [eval_bare()]). | ||||||||
| #' | ||||||||
| #' `locally()` is equivalent to the base function | ||||||||
| #' [base::local()] but it produces a much cleaner | ||||||||
| #' evaluation stack, and has stack-consistent semantics. It is thus | ||||||||
| #' more suited for experimenting with the R language. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @section Life cycle: | ||||||||
| #' | ||||||||
| #' These functions are experimental. Expect API changes. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @inheritParams eval_bare | ||||||||
| #' @param env An environment within which to evaluate `expr`. Can be | ||||||||
| #' an object with a [get_env()] method. | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # with_env() is handy to create formulas with a given environment: | ||||||||
| #' env <- child_env("rlang") | ||||||||
| #' f <- with_env(env, ~new_formula()) | ||||||||
| #' identical(f_env(f), env) | ||||||||
| #' | ||||||||
| #' # Or functions with a given enclosure: | ||||||||
| #' fn <- with_env(env, function() NULL) | ||||||||
| #' identical(get_env(fn), env) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' # Unlike eval() it doesn't create duplicates on the evaluation | ||||||||
| #' # stack. You can thus use it e.g. to create non-local returns: | ||||||||
| #' fn <- function() { | ||||||||
| #' g(current_env()) | ||||||||
| #' "normal return" | ||||||||
| #' } | ||||||||
| #' g <- function(env) { | ||||||||
| #' with_env(env, return("early return")) | ||||||||
| #' } | ||||||||
| #' fn() | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' # Since env is passed to as_environment(), it can be any object with an | ||||||||
| #' # as_environment() method. For strings, the pkg_env() is returned: | ||||||||
| #' with_env("base", ~mtcars) | ||||||||
| #' | ||||||||
| #' # This can be handy to put dictionaries in scope: | ||||||||
| #' with_env(mtcars, cyl) | ||||||||
| with_env <- function(env, expr) { | ||||||||
| .External2(rlang_ext2_eval, substitute(expr), as_environment(env, caller_env())) | ||||||||
| } | ||||||||
| #' @rdname with_env | ||||||||
| #' @export | ||||||||
| locally <- function(expr) { | ||||||||
| .External2(rlang_ext2_eval, substitute(expr), child_env(caller_env())) | ||||||||
| } | ||||||||
| #' Invoke a function with a list of arguments | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' \Sexpr[results=rd, stage=render]{rlang:::lifecycle("soft-deprecated")} | ||||||||
| #' | ||||||||
| #' Normally, you invoke a R function by typing arguments manually. A | ||||||||
| #' powerful alternative is to call a function with a list of arguments | ||||||||
| #' assembled programmatically. This is the purpose of `invoke()`. | ||||||||
| #' | ||||||||
| #' @details | ||||||||
| #' | ||||||||
| #' Technically, `invoke()` is basically a version of [base::do.call()] | ||||||||
| #' that creates cleaner call traces because it does not inline the | ||||||||
| #' function and the arguments in the call (see examples). To achieve | ||||||||
| #' this, `invoke()` creates a child environment of `.env` with `.fn` | ||||||||
| #' and all arguments bound to new symbols (see [env_bury()]). It then | ||||||||
| #' uses the same strategy as [eval_bare()] to evaluate with minimal | ||||||||
| #' noise. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @section Life cycle: | ||||||||
| #' | ||||||||
| #' `invoke()` is soft-deprecated in favour of [exec()]. Now that we | ||||||||
| #' understand better the interaction between unquoting and dots | ||||||||
| #' capture, we can take a simpler approach in `exec()`. | ||||||||
| #' | ||||||||
| #' If you need finer control over the generated call, you should construct | ||||||||
| #' an environment and call yourself, manually burying large objects | ||||||||
| #' or complex expressions. | ||||||||
| #' | ||||||||
| #' @param .fn A function to invoke. Can be a function object or the | ||||||||
| #' name of a function in scope of `.env`. | ||||||||
| #' @param .args,... List of arguments (possibly named) to be passed to | ||||||||
| #' `.fn`. | ||||||||
| #' @param .env The environment in which to call `.fn`. | ||||||||
| #' @param .bury A character vector of length 2. The first string | ||||||||
| #' specifies which name should the function have in the call | ||||||||
| #' recorded in the evaluation stack. The second string specifies a | ||||||||
| #' prefix for the argument names. Set `.bury` to `NULL` if you | ||||||||
| #' prefer to inline the function and its arguments in the call. | ||||||||
| #' @export | ||||||||
| #' @keywords internal | ||||||||
| #' @examples | ||||||||
| #' # invoke() has the same purpose as do.call(): | ||||||||
| #' invoke(paste, letters) | ||||||||
| #' | ||||||||
| #' # But it creates much cleaner calls: | ||||||||
| #' invoke(call_inspect, mtcars) | ||||||||
| #' | ||||||||
| #' # and stacktraces: | ||||||||
| #' fn <- function(...) sys.calls() | ||||||||
| #' invoke(fn, list(mtcars)) | ||||||||
| #' | ||||||||
| #' # Compare to do.call(): | ||||||||
| #' do.call(call_inspect, mtcars) | ||||||||
| #' do.call(fn, list(mtcars)) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' # Specify the function name either by supplying a string | ||||||||
| #' # identifying the function (it should be visible in .env): | ||||||||
| #' invoke("call_inspect", letters) | ||||||||
| #' | ||||||||
| #' # Or by changing the .bury argument, with which you can also change | ||||||||
| #' # the argument prefix: | ||||||||
| #' invoke(call_inspect, mtcars, .bury = c("inspect!", "col")) | ||||||||
| invoke <- function(.fn, .args = list(), ..., | ||||||||
| .env = caller_env(), .bury = c(".fn", "")) { | ||||||||
| signal_soft_deprecated(c( | ||||||||
| "`invoke()` is deprecated as of rlang 0.4.0.", | ||||||||
| "Please use `exec()` or `eval(expr())`instead." | ||||||||
| )) | ||||||||
| args <- c(.args, list(...)) | ||||||||
| if (is_null(.bury) || !length(args)) { | ||||||||
| if (is_scalar_character(.fn)) { | ||||||||
| .fn <- env_get(.env, .fn, inherit = TRUE) | ||||||||
| } | ||||||||
| call <- call2(.fn, !!! args) | ||||||||
| return(.External2(rlang_ext2_eval, call, .env)) | ||||||||
| } | ||||||||
| if (!is_character(.bury, 2L)) { | ||||||||
| abort("`.bury` must be a character vector of length 2") | ||||||||
| } | ||||||||
| arg_prefix <- .bury[[2]] | ||||||||
| fn_nm <- .bury[[1]] | ||||||||
| buried_nms <- paste0(arg_prefix, seq_along(args)) | ||||||||
| buried_args <- set_names(args, buried_nms) | ||||||||
| .env <- env_bury(.env, !!! buried_args) | ||||||||
| args <- set_names(buried_nms, names(args)) | ||||||||
| args <- syms(args) | ||||||||
| if (is_function(.fn)) { | ||||||||
| env_bind(.env, !! fn_nm := .fn) | ||||||||
| .fn <- fn_nm | ||||||||
| } | ||||||||
| call <- call2(.fn, !!! args) | ||||||||
| .External2(rlang_ext2_eval, call, .env) | ||||||||
| } | ||||||||
| value <- function(expr) { | ||||||||
| eval_bare(enexpr(expr), caller_env()) | ||||||||
| } | ||||||||
| eval_top <- function(expr, env = caller_env()) { | ||||||||
| .Call(rlang_eval_top, expr, env) | ||||||||
| } | ||||||||
| #' Execute a function | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' This function constructs and evaluates a call to `.fn`. | ||||||||
| #' It has two primary uses: | ||||||||
| #' | ||||||||
| #' * To call a function with arguments stored in a list (if the | ||||||||
| #' function doesn't support [dynamic dots][dyn-dots]). Splice the | ||||||||
| #' list of arguments with `!!!`. | ||||||||
| #' | ||||||||
| #' * To call every function stored in a list (in conjunction with `map()`/ | ||||||||
| #' [lapply()]) | ||||||||
| #' | ||||||||
| #' @param .fn A function, or function name as a string. | ||||||||
| #' @param ... <[dynamic][dyn-dots]> Arguments for `.fn`. | ||||||||
| #' @param .env Environment in which to evaluate the call. This will be | ||||||||
| #' most useful if `f` is a string, or the function has side-effects. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' args <- list(x = c(1:10, 100, NA), na.rm = TRUE) | ||||||||
| #' exec("mean", !!!args) | ||||||||
| #' exec("mean", !!!args, trim = 0.2) | ||||||||
| #' | ||||||||
| #' fs <- list(a = function() "a", b = function() "b") | ||||||||
| #' lapply(fs, exec) | ||||||||
| #' | ||||||||
| #' # Compare to do.call it will not automatically inline expressions | ||||||||
| #' # into the evaluated call. | ||||||||
| #' x <- 10 | ||||||||
| #' args <- exprs(x1 = x + 1, x2 = x * 2) | ||||||||
| #' exec(list, !!!args) | ||||||||
| #' do.call(list, args) | ||||||||
| #' | ||||||||
| #' # exec() is not designed to generate pretty function calls. This is | ||||||||
| #' # most easily seen if you call a function that captures the call: | ||||||||
| #' f <- disp ~ cyl | ||||||||
| #' exec("lm", f, data = mtcars) | ||||||||
| #' | ||||||||
| #' # If you need finer control over the generated call, you'll need to | ||||||||
| #' # construct it yourself. This may require creating a new environment | ||||||||
| #' # with carefully constructed bindings | ||||||||
| #' data_env <- env(data = mtcars) | ||||||||
| #' eval(expr(lm(!!f, data)), data_env) | ||||||||
| exec <- function(.fn, ..., .env = caller_env()) { | ||||||||
| .External2(rlang_ext2_exec, .fn, .env) | ||||||||
| } | ||||||||
| #' Inject objects in an R expression | ||||||||
| #' | ||||||||
| #' `inject()` evaluates an expression with [injection][quasiquotation] | ||||||||
| #' (unquotation) support. There are three main usages: | ||||||||
| #' | ||||||||
| #' - [Splicing][!!!] lists of arguments in a function call. | ||||||||
| #' | ||||||||
| #' - Inline objects or other expressions in an expression with `!!` | ||||||||
| #' and `!!!`. For instance to create functions or formulas | ||||||||
| #' programmatically. | ||||||||
| #' | ||||||||
| #' - Pass arguments to NSE functions that [defuse][nse-defuse] their | ||||||||
| #' arguments without injection support (see for instance | ||||||||
| #' [enquo0()]). You can use `{{ arg }}` with functions documented | ||||||||
| #' to support quosures. Otherwise, use `!!enexpr(arg)`. | ||||||||
| #' | ||||||||
| #' @param expr An argument to evaluate. This argument is immediately | ||||||||
| #' evaluated in `env` (the current environment by default) with | ||||||||
| #' injected objects and expressions. | ||||||||
| #' @param env The environment in which to evaluate `expr`. Defaults to | ||||||||
| #' the current environment. For expert use only. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # inject() simply evaluates its argument with injection | ||||||||
| #' # support. These expressions are equivalent: | ||||||||
| #' 2 * 3 | ||||||||
| #' inject(2 * 3) | ||||||||
| #' inject(!!2 * !!3) | ||||||||
| #' | ||||||||
| #' # Injection with `!!` can be useful to insert objects or | ||||||||
| #' # expressions within other expressions, like formulas: | ||||||||
| #' lhs <- sym("foo") | ||||||||
| #' rhs <- sym("bar") | ||||||||
| #' inject(!!lhs ~ !!rhs + 10) | ||||||||
| #' | ||||||||
| #' # Injection with `!!!` splices lists of arguments in function | ||||||||
| #' # calls: | ||||||||
| #' args <- list(na.rm = TRUE, finite = 0.2) | ||||||||
| #' inject(mean(1:10, !!!args)) | ||||||||
| inject <- function(expr, env = caller_env()) { | ||||||||
| .External2(rlang_ext2_eval, enexpr(expr), env) | ||||||||
| } | ||||||||
| 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") { | ||||||||
| u <- unit(c(t, r, b, l), unit) | ||||||||
| class(u) <- c("margin", class(u)) | ||||||||
| u | ||||||||
| } | ||||||||
| 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, check.overlap = 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, | ||||||||
| check.overlap = check.overlap | ||||||||
| ) | ||||||||
| # 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[1] / 180 * pi)) * descent | ||||||||
| text_width <- unit(1, "grobwidth", text_grob) + abs(sin(angle[1] / 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 A gList containing a grob, such as a text grob | ||||||||
| #' @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, check.overlap = 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, | ||||||||
| check.overlap = check.overlap | ||||||||
| ) | ||||||||
| 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 { | ||||||||
| abort("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()) | ||||||||
| # Important: This function is not vectorized. Do not use to look up multiple | ||||||||
| # font descents at once. | ||||||||
| font_descent <- function(family = "", face = "plain", size = 12, cex = 1) { | ||||||||
| cur_dev <- names(grDevices::dev.cur()) | ||||||||
| if (cur_dev == "null device") { | ||||||||
| cache <- FALSE # don't cache if no device open | ||||||||
| } else { | ||||||||
| cache <- TRUE | ||||||||
| } | ||||||||
| key <- paste0(cur_dev, ':', family, ':', face, ":", size, ":", cex) | ||||||||
| # we only look up the first result; this function is not vectorized | ||||||||
| key <- key[1] | ||||||||
| descent <- descent_cache[[key]] | ||||||||
| if (is.null(descent)) { | ||||||||
| descent <- convertHeight(grobDescent(textGrob( | ||||||||
| label = "gjpqyQ", | ||||||||
| gp = gpar( | ||||||||
| fontsize = size, | ||||||||
| cex = cex, | ||||||||
| fontfamily = family, | ||||||||
| fontface = face | ||||||||
| ) | ||||||||
| )), 'inches') | ||||||||
| if (cache) { | ||||||||
| descent_cache[[key]] <- descent | ||||||||
| } | ||||||||
| } | ||||||||
| descent | ||||||||
| } | ||||||||
| 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) { | ||||||||
| warn("Referring to `x` is deprecated, use variable name instead") | ||||||||
| # 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)) { | ||||||||
| abort("Supply one of rows or cols") | ||||||||
| } | ||||||||
| if (attr(labels, "facet") == "wrap") { | ||||||||
| # Return either rows or cols for facet_wrap() | ||||||||
| if (!is.null(cols) && !is.null(rows)) { | ||||||||
| abort("Cannot supply both rows and cols to facet_wrap()") | ||||||||
| } | ||||||||
| 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()] or [facet_wrap()] | ||||||||
| #' 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 | ||||||||
| #' idx <- match(msleep$conservation, names(conservation_status)) | ||||||||
| #' msleep$conservation2 <- conservation_status[idx] | ||||||||
| #' | ||||||||
| #' 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))) { | ||||||||
| abort(glue( | ||||||||
| "Conflict between .{attr(labels, 'type')} and ", | ||||||||
| glue_collapse(names(dots), ", ", last = " and ") | ||||||||
| )) | ||||||||
| } | ||||||||
| } | ||||||||
| # 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) | ||||||||
| }) | ||||||||
| } | ||||||||
| # Create matrix of labels | ||||||||
| labels <- lapply(labeller(label_df), cbind) | ||||||||
| labels <- do.call("cbind", labels) | ||||||||
| ncol <- ncol(labels) | ||||||||
| nrow <- nrow(labels) | ||||||||
| if (horizontal) { | ||||||||
| grobs_top <- lapply(labels, element_render, theme = theme, | ||||||||
| element = "strip.text.x.top", margin_x = TRUE, | ||||||||
| margin_y = TRUE) | ||||||||
| grobs_top <- assemble_strips(matrix(grobs_top, ncol = ncol, nrow = nrow), | ||||||||
| theme, horizontal, clip = "on") | ||||||||
| grobs_bottom <- lapply(labels, element_render, theme = theme, | ||||||||
| element = "strip.text.x.bottom", margin_x = TRUE, | ||||||||
| margin_y = TRUE) | ||||||||
| grobs_bottom <- assemble_strips(matrix(grobs_bottom, ncol = ncol, nrow = nrow), | ||||||||
| theme, horizontal, clip = "on") | ||||||||
| list( | ||||||||
| top = grobs_top, | ||||||||
| bottom = grobs_bottom | ||||||||
| ) | ||||||||
| } else { | ||||||||
| grobs_left <- lapply(labels, element_render, theme = theme, | ||||||||
| element = "strip.text.y.left", margin_x = TRUE, | ||||||||
| margin_y = TRUE) | ||||||||
| grobs_left <- assemble_strips(matrix(grobs_left, ncol = ncol, nrow = nrow), | ||||||||
| theme, horizontal, clip = "on") | ||||||||
| grobs_right <- lapply(labels[, rev(seq_len(ncol(labels))), drop = FALSE], | ||||||||
| element_render, theme = theme, | ||||||||
| element = "strip.text.y.right", margin_x = TRUE, | ||||||||
| margin_y = TRUE) | ||||||||
| grobs_right <- assemble_strips(matrix(grobs_right, ncol = ncol, nrow = nrow), | ||||||||
| theme, horizontal, clip = "on") | ||||||||
| list( | ||||||||
| left = grobs_left, | ||||||||
| right = grobs_right | ||||||||
| ) | ||||||||
| } | ||||||||
| } | ||||||||
| #' 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 [titleGrob()]. | ||||||||
| #' @param theme Theme object. | ||||||||
| #' @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 | ||||||||
| assemble_strips <- function(grobs, theme, horizontal = TRUE, clip) { | ||||||||
| if (length(grobs) == 0 || is.zero(grobs[[1]])) return(grobs) | ||||||||
| # Add margins to non-titleGrobs so they behave eqivalently | ||||||||
| grobs[] <- lapply(grobs, function(g) { | ||||||||
| if (inherits(g, "titleGrob")) return(g) | ||||||||
| add_margins(gList(g), grobHeight(g), grobWidth(g), margin_x = TRUE, margin_y = TRUE) | ||||||||
| }) | ||||||||
| if (horizontal) { | ||||||||
| height <- max_height(lapply(grobs, function(x) x$heights[2])) | ||||||||
| width <- unit(1, "null") | ||||||||
| } else { | ||||||||
| height <- unit(1, "null") | ||||||||
| width <- max_width(lapply(grobs, function(x) x$widths[2])) | ||||||||
| } | ||||||||
| grobs[] <- lapply(grobs, function(x) { | ||||||||
| # Avoid unit subset assignment to support R 3.2 | ||||||||
| x$widths <- unit.c(x$widths[1], width, x$widths[c(-1, -2)]) | ||||||||
| x$heights <- unit.c(x$heights[1], height, x$heights[c(-1, -2)]) | ||||||||
| x$vp$parent$layout$widths <- unit.c(x$vp$parent$layout$widths[1], width, x$vp$parent$layout$widths[c(-1, -2)]) | ||||||||
| x$vp$parent$layout$heights <- unit.c(x$vp$parent$layout$heights[1], height, x$vp$parent$layout$heights[c(-1, -2)]) | ||||||||
| x | ||||||||
| }) | ||||||||
| if (horizontal) { | ||||||||
| height <- sum(grobs[[1]]$heights) | ||||||||
| } else { | ||||||||
| width <- sum(grobs[[1]]$widths) | ||||||||
| } | ||||||||
| background <- if (horizontal) "strip.background.x" else "strip.background.y" | ||||||||
| background <- element_render(theme, background) | ||||||||
| # Put text on a strip | ||||||||
| grobs[] <- lapply(grobs, function(x) { | ||||||||
| ggname("strip", gTree(children = gList(background, x))) | ||||||||
| }) | ||||||||
| 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) | ||||||||
| }) | ||||||||
| } | ||||||||
| # 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) | ||||||||
| } | ||||||||
| warn(glue( | ||||||||
| "The labeller API has been updated. Labellers taking `variable` ", | ||||||||
| "and `value` arguments are now deprecated. See labellers documentation.")) | ||||||||
| } | ||||||||
| labeller | ||||||||
| } | ||||||||
| 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). | ||||||||
| #' | ||||||||
| #' @return A gtable object | ||||||||
| #' | ||||||||
| #' @family gtable construction | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' | ||||||||
| #' @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] | ||||||||
| if ((length(rows) > 1 && any(diff(rows) < 1)) || | ||||||||
| (length(cols) > 1 && any(diff(cols) < 1))) { | ||||||||
| stop("i and j must be increasing sequences of numbers", call. = FALSE) | ||||||||
| } | ||||||||
| 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/gtable-layouts.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Create a single column gtable | ||||||||
| #' | ||||||||
| #' This function stacks a list of grobs into a single column gtable of the given | ||||||||
| #' width and heights. | ||||||||
| #' | ||||||||
| #' @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). | ||||||||
| #' | ||||||||
| #' @return A gtable with one column and as many rows as elements in the grobs | ||||||||
| #' list. | ||||||||
| #' | ||||||||
| #' @family gtable construction | ||||||||
| #' | ||||||||
| #' @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(widths = width, heights = heights, name = name, vp = vp, | ||||||||
| rownames = names(grobs)) | ||||||||
| table <- gtable_add_grob(table, grobs, | ||||||||
| t = seq_along(grobs), l = 1, | ||||||||
| z = z, clip = "off" | ||||||||
| ) | ||||||||
| table | ||||||||
| } | ||||||||
| #' Create a single row gtable. | ||||||||
| #' | ||||||||
| #' This function puts grobs in a list side-by-side in a single-row gtable from | ||||||||
| #' left to right witrh the given widths and height. | ||||||||
| #' | ||||||||
| #' @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). | ||||||||
| #' | ||||||||
| #' @return A gtable with a single row and the same number of columns as | ||||||||
| #' elements in the grobs list | ||||||||
| #' | ||||||||
| #' @family gtable construction | ||||||||
| #' | ||||||||
| #' @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(widths = widths, heights = height, name = name, vp = vp, | ||||||||
| colnames = names(grobs)) | ||||||||
| 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. | ||||||||
| #' | ||||||||
| #' This function takes a matrix of grobs and create a gtable matching with the | ||||||||
| #' grobs in the same position as they were in the matrix, with the given heights | ||||||||
| #' and widths. | ||||||||
| #' | ||||||||
| #' @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). | ||||||||
| #' | ||||||||
| #' @return A gtable of the same dimensions as the grobs matrix. | ||||||||
| #' | ||||||||
| #' @family gtable construction | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' | ||||||||
| #' @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) { | ||||||||
| 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(widths = widths, heights = heights, name = name, | ||||||||
| respect = respect, vp = vp, | ||||||||
| rownames = rownames(grobs), colnames = colnames(grobs)) | ||||||||
| 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. | ||||||||
| #' | ||||||||
| #' Create a zero-column or zero-row gtable with the given heights or widths | ||||||||
| #' respectively. | ||||||||
| #' | ||||||||
| #' @name gtable_spacer | ||||||||
| #' | ||||||||
| #' @return A gtable object | ||||||||
| #' | ||||||||
| #' @family gtable construction | ||||||||
| 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) | ||||||||
| } | ||||||||
| 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) { | ||||||||
| if (is.null(required)) return() | ||||||||
| required <- strsplit(required, "|", fixed = TRUE) | ||||||||
| if (any(vapply(required, length, integer(1)) > 1)) { | ||||||||
| required <- lapply(required, rep_len, 2) | ||||||||
| required <- list( | ||||||||
| vapply(required, `[`, character(1), 1), | ||||||||
| vapply(required, `[`, character(1), 2) | ||||||||
| ) | ||||||||
| } else { | ||||||||
| required <- list(unlist(required)) | ||||||||
| } | ||||||||
| missing_aes <- lapply(required, setdiff, present) | ||||||||
| if (any(vapply(missing_aes, length, integer(1)) == 0)) return() | ||||||||
| abort(glue( | ||||||||
| "{name} requires the following missing aesthetics: ", | ||||||||
| glue_collapse(lapply(missing_aes, glue_collapse, sep = ", ", last = " and "), sep = " or ") | ||||||||
| )) | ||||||||
| } | ||||||||
| # 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 = "") | ||||||||
| } | ||||||||
| # Test whether package `package` is available. `fun` provides | ||||||||
| # the name of the ggplot2 function that uses this package, and is | ||||||||
| # used only to produce a meaningful error message if the | ||||||||
| # package is not available. | ||||||||
| try_require <- function(package, fun) { | ||||||||
| if (requireNamespace(package, quietly = TRUE)) { | ||||||||
| return(invisible()) | ||||||||
| } | ||||||||
| abort(glue(" | ||||||||
| Package `{package}` required for `{fun}`. | ||||||||
| Please install and try again. | ||||||||
| ")) | ||||||||
| } | ||||||||
| # 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) { | ||||||||
| if (!is.logical(na.rm)) { | ||||||||
| abort("`na.rm` must be logical") | ||||||||
| } | ||||||||
| missing <- detect_missing(df, vars, finite) | ||||||||
| if (any(missing)) { | ||||||||
| df <- df[!missing, ] | ||||||||
| if (!na.rm) { | ||||||||
| if (name != "") name <- paste(" (", name, ")", sep = "") | ||||||||
| str <- if (finite) "non-finite" else "missing" | ||||||||
| warning_wrap( | ||||||||
| "Removed ", sum(missing), " rows containing ", str, " values", name, "." | ||||||||
| ) | ||||||||
| } | ||||||||
| } | ||||||||
| df | ||||||||
| } | ||||||||
| detect_missing <- function(df, vars, finite = FALSE) { | ||||||||
| vars <- intersect(vars, names(df)) | ||||||||
| !cases(df[, vars, drop = FALSE], if (finite) is_finite else is_complete) | ||||||||
| } | ||||||||
| # 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")) { | ||||||||
| abort("No error!") | ||||||||
| } | ||||||||
| 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]) | ||||||||
| } | ||||||||
| binned_pal <- function(palette) { | ||||||||
| function(x) { | ||||||||
| palette(length(x)) | ||||||||
| } | ||||||||
| } | ||||||||
| #' Give a deprecation error, warning, or message, depending on version number. | ||||||||
| #' | ||||||||
| #' This function is deprecated. | ||||||||
| #' | ||||||||
| #' @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) { | ||||||||
| .Deprecated() | ||||||||
| v <- as.package_version(version) | ||||||||
| cv <- utils::packageVersion("ggplot2") | ||||||||
| text <- "{msg} (Defunct; last used in version {version})" | ||||||||
| # 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) { | ||||||||
| abort(glue(text)) | ||||||||
| # If minor number differs by one, give warning | ||||||||
| } else if (cv[[1,2]] > v[[1,2]]) { | ||||||||
| warn(glue(text)) | ||||||||
| # If only subminor number is greater, give message | ||||||||
| } else if (cv[[1,3]] > v[[1,3]]) { | ||||||||
| message(glue(text)) | ||||||||
| } | ||||||||
| invisible() | ||||||||
| } | ||||||||
| has_name <- function(x) { | ||||||||
| nms <- names(x) | ||||||||
| if (is.null(nms)) { | ||||||||
| return(rep(FALSE, length(x))) | ||||||||
| } | ||||||||
| !is.na(nms) & nms != "" | ||||||||
| } | ||||||||
| # Use chartr() for safety since toupper() fails to convert i to I in Turkish locale | ||||||||
| lower_ascii <- "abcdefghijklmnopqrstuvwxyz" | ||||||||
| upper_ascii <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ" | ||||||||
| to_lower_ascii <- function(x) chartr(upper_ascii, lower_ascii, x) | ||||||||
| to_upper_ascii <- function(x) chartr(lower_ascii, upper_ascii, x) | ||||||||
| tolower <- function(x) { | ||||||||
| abort("Please use `to_lower_ascii()`, which works fine in all locales.") | ||||||||
| } | ||||||||
| toupper <- function(x) { | ||||||||
| abort("Please use `to_upper_ascii()`, which works fine in all locales.") | ||||||||
| } | ||||||||
| # 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) | ||||||||
| to_lower_ascii(x) | ||||||||
| } | ||||||||
| firstUpper <- function(s) { | ||||||||
| paste0(to_upper_ascii(substring(s, 1, 1)), substring(s, 2)) | ||||||||
| } | ||||||||
| snake_class <- function(x) { | ||||||||
| snakeize(class(x)[1]) | ||||||||
| } | ||||||||
| empty <- function(df) { | ||||||||
| is.null(df) || nrow(df) == 0 || ncol(df) == 0 || is.waive(df) | ||||||||
| } | ||||||||
| is.discrete <- function(x) { | ||||||||
| is.factor(x) || is.character(x) || is.logical(x) | ||||||||
| } | ||||||||
| # This function checks that all columns of a dataframe `x` are data and returns | ||||||||
| # the names of any columns that are not. | ||||||||
| # We define "data" as atomic types or lists, not functions or otherwise. | ||||||||
| # The `inherits(x, "Vector")` check is for checking S4 classes from Bioconductor | ||||||||
| # and wether they can be expected to follow behavior typical of vectors. See | ||||||||
| # also #3835 | ||||||||
| check_nondata_cols <- function(x) { | ||||||||
| idx <- (vapply(x, function(x) { | ||||||||
| is.null(x) || rlang::is_vector(x) || inherits(x, "Vector") | ||||||||
| }, logical(1))) | ||||||||
| names(x)[which(!idx)] | ||||||||
| } | ||||||||
| 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) | ||||||||
| warn(glue_collapse(wrapped, "\n", last = "\n")) | ||||||||
| } | ||||||||
| 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(list(x = NA), n = 1) | ||||||||
| 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) | ||||||||
| new_data_frame(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) { | ||||||||
| if (!is.character(text)) { | ||||||||
| abort("`text` must be a character vector") | ||||||||
| } | ||||||||
| 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 | ||||||||
| } | ||||||||
| switch_orientation <- function(aesthetics) { | ||||||||
| # We should have these as globals somewhere | ||||||||
| x <- ggplot_global$x_aes | ||||||||
| y <- ggplot_global$y_aes | ||||||||
| x_aes <- match(aesthetics, x) | ||||||||
| x_aes_pos <- which(!is.na(x_aes)) | ||||||||
| y_aes <- match(aesthetics, y) | ||||||||
| y_aes_pos <- which(!is.na(y_aes)) | ||||||||
| if (length(x_aes_pos) > 0) { | ||||||||
| aesthetics[x_aes_pos] <- y[x_aes[x_aes_pos]] | ||||||||
| } | ||||||||
| if (length(y_aes_pos) > 0) { | ||||||||
| aesthetics[y_aes_pos] <- x[y_aes[y_aes_pos]] | ||||||||
| } | ||||||||
| aesthetics | ||||||||
| } | ||||||||
| #' Utilities for working with bidirectional layers | ||||||||
| #' | ||||||||
| #' These functions are what underpins the ability of certain geoms to work | ||||||||
| #' automatically in both directions. See the *Extending ggplot2* vignette for | ||||||||
| #' how they are used when implementing `Geom`, `Stat`, and `Position` classes. | ||||||||
| #' | ||||||||
| #' `has_flipped_aes()` is used to sniff out the orientation of the layer from | ||||||||
| #' the data. It has a range of arguments that can be used to finetune the | ||||||||
| #' sniffing based on what the data should look like. `flip_data()` will switch | ||||||||
| #' the column names of the data so that it looks like x-oriented data. | ||||||||
| #' `flipped_names()` provides a named list of aesthetic names that corresponds | ||||||||
| #' to the orientation of the layer. | ||||||||
| #' | ||||||||
| #' @section Controlling the sniffing: | ||||||||
| #' How the layer data should be interpreted depends on its specific features. | ||||||||
| #' `has_flipped_aes()` contains a range of flags for defining what certain | ||||||||
| #' features in the data correspond to: | ||||||||
| #' | ||||||||
| #' - `main_is_orthogonal`: This argument controls how the existence of only a `x` | ||||||||
| #' or `y` aesthetic is understood. If `TRUE` then the exisiting aesthetic | ||||||||
| #' would be then secondary axis. This behaviour is present in [stat_ydensity()] | ||||||||
| #' and [stat_boxplot()]. If `FALSE` then the exisiting aesthetic is the main | ||||||||
| #' axis as seen in e.g. [stat_bin()], [geom_count()], and [stat_density()]. | ||||||||
| #' - `range_is_orthogonal`: This argument controls whether the existance of | ||||||||
| #' range-like aesthetics (e.g. `xmin` and `xmax`) represents the main or | ||||||||
| #' secondary axis. If `TRUE` then the range is given for the secondary axis as | ||||||||
| #' seen in e.g. [geom_ribbon()] and [geom_linerange()]. | ||||||||
| #' - `group_has_equal`: This argument controls whether to test for equality of | ||||||||
| #' all `x` and `y` values inside each group and set the main axis to the one | ||||||||
| #' where all is equal. This test is only performed if `TRUE`, and only after | ||||||||
| #' less computationally heavy tests has come up empty handed. Examples are | ||||||||
| #' [stat_boxplot()] and [stat_ydensity] | ||||||||
| #' - `ambiguous`: This argument tells the function that the layer, while | ||||||||
| #' bidirectional, doesn't treat each axis differently. It will circumvent any | ||||||||
| #' data based guessing and only take hint from the `orientation` element in | ||||||||
| #' `params`. If this is not present it will fall back to `FALSE`. Examples are | ||||||||
| #' [geom_line()] and [geom_area()] | ||||||||
| #' - `main_is_continuous`: This argument controls how the test for discreteness | ||||||||
| #' in the scales should be interpreted. If `TRUE` then the main axis will be | ||||||||
| #' the one which is not discrete-like. Conversely, if `FALSE` the main axis | ||||||||
| #' will be the discrete-like one. Examples of `TRUE` is [stat_density()] and | ||||||||
| #' [stat_bin()], while examples of `FALSE` is [stat_ydensity()] and | ||||||||
| #' [stat_boxplot()] | ||||||||
| #' - `main_is_optional`: This argument controls the rare case of layers were the | ||||||||
| #' main direction is an optional aesthetic. This is only seen in | ||||||||
| #' [stat_boxplot()] where `x` is set to `0` if not given. If `TRUE` there will | ||||||||
| #' be a check for whether all `x` or all `y` are equal to `0` | ||||||||
| #' | ||||||||
| #' @param data The layer data | ||||||||
| #' @param params The parameters of the `Stat`/`Geom`. Only the `orientation` | ||||||||
| #' parameter will be used. | ||||||||
| #' @param main_is_orthogonal If only `x` or `y` are present do they correspond | ||||||||
| #' to the main orientation or the reverse. E.g. If `TRUE` and `y` is present | ||||||||
| #' it is not flipped. If `NA` this check will be ignored. | ||||||||
| #' @param range_is_orthogonal If `xmin`/`xmax` or `ymin`/`ymax` is present do | ||||||||
| #' they correspond to the main orientation or reverse. If `NA` this check will | ||||||||
| #' be ignored. | ||||||||
| #' @param group_has_equal Is it expected that grouped data has either a single | ||||||||
| #' `x` or `y` value that will correspond to the orientation. | ||||||||
| #' @param ambiguous Is the layer ambiguous in its mapping by nature. If so, it | ||||||||
| #' will only be flipped if `params$orientation == "y"` | ||||||||
| #' @param main_is_continuous If there is a discrete and continuous axis, does | ||||||||
| #' the continuous one correspond to the main orientation? | ||||||||
| #' @param main_is_optional Is the main axis aesthetic optional and, if not | ||||||||
| #' given, set to `0` | ||||||||
| #' @param flip Logical. Is the layer flipped. | ||||||||
| #' | ||||||||
| #' @return `has_flipped_aes()` returns `TRUE` if it detects a layer in the other | ||||||||
| #' orientation and `FALSE` otherwise. `flip_data()` will return the input | ||||||||
| #' unchanged if `flip = FALSE` and the data with flipped aesthetic names if | ||||||||
| #' `flip = TRUE`. `flipped_names()` returns a named list of strings. If | ||||||||
| #' `flip = FALSE` the name of the element will correspond to the element, e.g. | ||||||||
| #' `flipped_names(FALSE)$x == "x"` and if `flip = TRUE` it will correspond to | ||||||||
| #' the flipped name, e.g. `flipped_names(FALSE)$x == "y"` | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @keywords internal | ||||||||
| #' @name bidirection | ||||||||
| #' | ||||||||
| has_flipped_aes <- function(data, params = list(), main_is_orthogonal = NA, | ||||||||
| range_is_orthogonal = NA, group_has_equal = FALSE, | ||||||||
| ambiguous = FALSE, main_is_continuous = FALSE, | ||||||||
| main_is_optional = FALSE) { | ||||||||
| # Is orientation already encoded in data? | ||||||||
| if (!is.null(data$flipped_aes)) { | ||||||||
| not_na <- which(!is.na(data$flipped_aes)) | ||||||||
| if (length(not_na) != 0) { | ||||||||
| return(data$flipped_aes[[not_na[1L]]]) | ||||||||
| } | ||||||||
| } | ||||||||
| # Is orientation requested in the params | ||||||||
| if (!is.null(params$orientation) && !is.na(params$orientation)) { | ||||||||
| return(params$orientation == "y") | ||||||||
| } | ||||||||
| x <- data$x %||% params$x | ||||||||
| y <- data$y %||% params$y | ||||||||
| xmin <- data$xmin %||% params$xmin | ||||||||
| ymin <- data$ymin %||% params$ymin | ||||||||
| xmax <- data$xmax %||% params$xmax | ||||||||
| ymax <- data$ymax %||% params$ymax | ||||||||
| # Does a single x or y aesthetic corespond to a specific orientation | ||||||||
| if (!is.na(main_is_orthogonal) && xor(is.null(x), is.null(y))) { | ||||||||
| return(is.null(y) == main_is_orthogonal) | ||||||||
| } | ||||||||
| has_x <- !is.null(x) | ||||||||
| has_y <- !is.null(y) | ||||||||
| # Does a provided range indicate an orientation | ||||||||
| if (!is.na(range_is_orthogonal)) { | ||||||||
| if (!is.null(ymin) || !is.null(ymax)) { | ||||||||
| return(!range_is_orthogonal) | ||||||||
| } | ||||||||
| if (!is.null(xmin) || !is.null(xmax)) { | ||||||||
| return(range_is_orthogonal) | ||||||||
| } | ||||||||
| } | ||||||||
| # If ambiguous orientation = NA will give FALSE | ||||||||
| if (ambiguous && (is.null(params$orientation) || is.na(params$orientation))) { | ||||||||
| return(FALSE) | ||||||||
| } | ||||||||
| # Is there a single actual discrete position | ||||||||
| y_is_discrete <- is_mapped_discrete(y) | ||||||||
| x_is_discrete <- is_mapped_discrete(x) | ||||||||
| if (xor(y_is_discrete, x_is_discrete)) { | ||||||||
| return(y_is_discrete != main_is_continuous) | ||||||||
| } | ||||||||
| # Does each group have a single x or y value | ||||||||
| if (group_has_equal) { | ||||||||
| if (has_x) { | ||||||||
| if (length(x) == 1) return(FALSE) | ||||||||
| x_groups <- vapply(split(data$x, data$group), function(x) length(unique(x)), integer(1)) | ||||||||
| if (all(x_groups == 1)) { | ||||||||
| return(FALSE) | ||||||||
| } | ||||||||
| } | ||||||||
| if (has_y) { | ||||||||
| if (length(y) == 1) return(TRUE) | ||||||||
| y_groups <- vapply(split(data$y, data$group), function(x) length(unique(x)), integer(1)) | ||||||||
| if (all(y_groups == 1)) { | ||||||||
| return(TRUE) | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| # default to no | ||||||||
| FALSE | ||||||||
| } | ||||||||
| #' @rdname bidirection | ||||||||
| #' @export | ||||||||
| flip_data <- function(data, flip = NULL) { | ||||||||
| flip <- flip %||% any(data$flipped_aes) %||% FALSE | ||||||||
| if (isTRUE(flip)) { | ||||||||
| names(data) <- switch_orientation(names(data)) | ||||||||
| } | ||||||||
| data | ||||||||
| } | ||||||||
| #' @rdname bidirection | ||||||||
| #' @export | ||||||||
| flipped_names <- function(flip = FALSE) { | ||||||||
| x_aes <- ggplot_global$x_aes | ||||||||
| y_aes <- ggplot_global$y_aes | ||||||||
| if (flip) { | ||||||||
| ret <- as.list(c(y_aes, x_aes)) | ||||||||
| } else { | ||||||||
| ret <- as.list(c(x_aes, y_aes)) | ||||||||
| } | ||||||||
| names(ret) <- c(x_aes, y_aes) | ||||||||
| ret | ||||||||
| } | ||||||||
| split_with_index <- function(x, f, n = max(f)) { | ||||||||
| if (n == 1) return(list(x)) | ||||||||
| f <- as.integer(f) | ||||||||
| attributes(f) <- list(levels = as.character(seq_len(n)), class = "factor") | ||||||||
| unname(split(x, f)) | ||||||||
| } | ||||||||
| ggplot2/R/scale-expansion.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Generate expansion vector for scales | ||||||||
| #' | ||||||||
| #' This is a convenience function for generating scale expansion vectors | ||||||||
| #' for the `expand` argument of [scale_(x|y)_continuous][scale_x_continuous()] | ||||||||
| #' and [scale_(x|y)_discrete][scale_x_discrete()]. The expansion vectors are used to | ||||||||
| #' add some space between the data and the axes. | ||||||||
| #' | ||||||||
| #' @param mult vector of multiplicative range expansion factors. | ||||||||
| #' If length 1, both the lower and upper limits of the scale | ||||||||
| #' are expanded outwards by `mult`. If length 2, the lower limit | ||||||||
| #' is expanded by `mult[1]` and the upper limit by `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 `add` units. If length 2, the | ||||||||
| #' lower limit is expanded by `add[1]` and the upper | ||||||||
| #' limit by `add[2]`. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # No space below the bars but 10% above them | ||||||||
| #' ggplot(mtcars) + | ||||||||
| #' geom_bar(aes(x = factor(cyl))) + | ||||||||
| #' scale_y_continuous(expand = expansion(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 = expansion(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 = expansion(add = .6)) + | ||||||||
| #' scale_y_continuous(expand = expansion(mult = .05)) | ||||||||
| #' | ||||||||
| expansion <- function(mult = 0, add = 0) { | ||||||||
| if (!(is.numeric(mult) && (length(mult) %in% 1:2) && is.numeric(add) && (length(add) %in% 1:2))) { | ||||||||
| abort("`mult` and `add` must be numeric vectors with 1 or 2 elements") | ||||||||
| } | ||||||||
| mult <- rep(mult, length.out = 2) | ||||||||
| add <- rep(add, length.out = 2) | ||||||||
| c(mult[1], add[1], mult[2], add[2]) | ||||||||
| } | ||||||||
| #' @rdname expansion | ||||||||
| #' @export | ||||||||
| expand_scale <- function(mult = 0, add = 0) { | ||||||||
| .Deprecated(msg = "`expand_scale()` is deprecated; use `expansion()` instead.") | ||||||||
| expansion(mult, add) | ||||||||
| } | ||||||||
| #' Expand a numeric range | ||||||||
| #' | ||||||||
| #' @param limits A numeric vector of length 2 giving the | ||||||||
| #' range to expand. | ||||||||
| #' @param expand A numeric vector of length 2 (`c(add, mult)`) | ||||||||
| #' or length 4 (`c(mult_left, add_left, mult_right, add_right)`), | ||||||||
| #' as generated by [expansion()]. | ||||||||
| #' | ||||||||
| #' @return The expanded `limits` | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| #' | ||||||||
| expand_range4 <- function(limits, expand) { | ||||||||
| if (!(is.numeric(expand) && length(expand) %in% c(2,4))) { | ||||||||
| abort("`expand` must be a numeric vector with 1 or 2 elements") | ||||||||
| } | ||||||||
| if (all(!is.finite(limits))) { | ||||||||
| return(c(-Inf, Inf)) | ||||||||
| } | ||||||||
| # 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) | ||||||||
| } | ||||||||
| #' Calculate the default expansion for a scale | ||||||||
| #' | ||||||||
| #' @param scale A position scale (e.g., [scale_x_continuous()] or [scale_x_discrete()]) | ||||||||
| #' @param discrete,continuous Default scale expansion factors for | ||||||||
| #' discrete and continuous scales, respectively. | ||||||||
| #' @param expand Should any expansion be applied? | ||||||||
| #' | ||||||||
| #' @return One of `discrete`, `continuous`, or `scale$expand` | ||||||||
| #' @noRd | ||||||||
| #' | ||||||||
| default_expansion <- function(scale, discrete = expansion(add = 0.6), | ||||||||
| continuous = expansion(mult = 0.05), expand = TRUE) { | ||||||||
| if (!expand) { | ||||||||
| return(expansion(0, 0)) | ||||||||
| } | ||||||||
| scale$expand %|W|% if (scale$is_discrete()) discrete else continuous | ||||||||
| } | ||||||||
| #' Expand limits in (possibly) transformed space | ||||||||
| #' | ||||||||
| #' These functions calculate the continuous range in coordinate space | ||||||||
| #' and in scale space. Usually these can be calculated from | ||||||||
| #' each other using the coordinate system transformation, except | ||||||||
| #' when transforming and expanding the scale limits results in values outside | ||||||||
| #' the domain of the transformation (e.g., a lower limit of 0 with a square root | ||||||||
| #' transformation). | ||||||||
| #' | ||||||||
| #' @param scale A position scale (see [scale_x_continuous()] and [scale_x_discrete()]) | ||||||||
| #' @param limits The initial scale limits, in scale-transformed space. | ||||||||
| #' @param coord_limits The user-provided limits in scale-transformed space, | ||||||||
| #' which may include one more more NA values, in which case those limits | ||||||||
| #' will fall back to the `limits`. In `expand_limits_scale()`, `coord_limits` | ||||||||
| #' are in user data space and can be `NULL` (unspecified), since the transformation | ||||||||
| #' from user to mapped space is different for each scale. | ||||||||
| #' @param expand An expansion generated by [expansion()] or [default_expansion()]. | ||||||||
| #' @param trans The coordinate system transformation. | ||||||||
| #' | ||||||||
| #' @return A list with components `continuous_range`, which is the | ||||||||
| #' expanded range in scale-transformed space, and `continuous_range_coord`, | ||||||||
| #' which is the expanded range in coordinate-transformed space. | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| #' | ||||||||
| expand_limits_scale <- function(scale, expand = expansion(0, 0), limits = waiver(), | ||||||||
| coord_limits = NULL) { | ||||||||
| limits <- limits %|W|% scale$get_limits() | ||||||||
| if (scale$is_discrete()) { | ||||||||
| coord_limits <- coord_limits %||% c(NA_real_, NA_real_) | ||||||||
| expand_limits_discrete( | ||||||||
| limits, | ||||||||
| expand, | ||||||||
| coord_limits, | ||||||||
| range_continuous = scale$range_c$range | ||||||||
| ) | ||||||||
| } else { | ||||||||
| # using the inverse transform to resolve the NA value is needed for date/datetime/time | ||||||||
| # scales, which refuse to transform objects of the incorrect type | ||||||||
| coord_limits <- coord_limits %||% scale$trans$inverse(c(NA_real_, NA_real_)) | ||||||||
| coord_limits_scale <- scale$trans$transform(coord_limits) | ||||||||
| expand_limits_continuous(limits, expand, coord_limits_scale) | ||||||||
| } | ||||||||
| } | ||||||||
| expand_limits_continuous <- function(limits, expand = expansion(0, 0), coord_limits = c(NA, NA)) { | ||||||||
| expand_limits_continuous_trans(limits, expand, coord_limits)$continuous_range | ||||||||
| } | ||||||||
| expand_limits_discrete <- function(limits, expand = expansion(0, 0), coord_limits = c(NA, NA), | ||||||||
| range_continuous = NULL) { | ||||||||
| limit_info <- expand_limits_discrete_trans( | ||||||||
| limits, | ||||||||
| expand, | ||||||||
| coord_limits, | ||||||||
| range_continuous = range_continuous | ||||||||
| ) | ||||||||
| limit_info$continuous_range | ||||||||
| } | ||||||||
| expand_limits_continuous_trans <- function(limits, expand = expansion(0, 0), | ||||||||
| coord_limits = c(NA, NA), trans = identity_trans()) { | ||||||||
| # let non-NA coord_limits override the scale limits | ||||||||
| limits <- ifelse(is.na(coord_limits), limits, coord_limits) | ||||||||
| # expand limits in coordinate space | ||||||||
| continuous_range_coord <- trans$transform(limits) | ||||||||
| # range expansion expects values in increasing order, which may not be true | ||||||||
| # for reciprocal/reverse transformations | ||||||||
| if (all(is.finite(continuous_range_coord)) && diff(continuous_range_coord) < 0) { | ||||||||
| continuous_range_coord <- rev(expand_range4(rev(continuous_range_coord), expand)) | ||||||||
| } else { | ||||||||
| continuous_range_coord <- expand_range4(continuous_range_coord, expand) | ||||||||
| } | ||||||||
| final_scale_limits <- trans$inverse(continuous_range_coord) | ||||||||
| # if any non-finite values were introduced in the transformations, | ||||||||
| # replace them with the original scale limits for the purposes of | ||||||||
| # calculating breaks and minor breaks from the scale | ||||||||
| continuous_range <- ifelse(is.finite(final_scale_limits), final_scale_limits, limits) | ||||||||
| list( | ||||||||
| continuous_range_coord = continuous_range_coord, | ||||||||
| continuous_range = continuous_range | ||||||||
| ) | ||||||||
| } | ||||||||
| expand_limits_discrete_trans <- function(limits, expand = expansion(0, 0), | ||||||||
| coord_limits = c(NA, NA), trans = identity_trans(), | ||||||||
| range_continuous = NULL) { | ||||||||
| if (is.discrete(limits)) { | ||||||||
| n_discrete_limits <- length(limits) | ||||||||
| } else { | ||||||||
| n_discrete_limits <- 0 | ||||||||
| } | ||||||||
| is_empty <- is.null(limits) && is.null(range_continuous) | ||||||||
| is_only_continuous <- n_discrete_limits == 0 | ||||||||
| is_only_discrete <- is.null(range_continuous) | ||||||||
| if (is_empty) { | ||||||||
| expand_limits_continuous_trans(c(0, 1), expand, coord_limits, trans) | ||||||||
| } else if (is_only_continuous) { | ||||||||
| expand_limits_continuous_trans(range_continuous, expand, coord_limits, trans) | ||||||||
| } else if (is_only_discrete) { | ||||||||
| expand_limits_continuous_trans(c(1, n_discrete_limits), expand, coord_limits, trans) | ||||||||
| } else { | ||||||||
| # continuous and discrete | ||||||||
| limit_info_discrete <- expand_limits_continuous_trans(c(1, n_discrete_limits), expand, coord_limits, trans) | ||||||||
| # don't expand continuous range if there is also a discrete range | ||||||||
| limit_info_continuous <- expand_limits_continuous_trans( | ||||||||
| range_continuous, expansion(0, 0), coord_limits, trans | ||||||||
| ) | ||||||||
| # prefer expanded discrete range, but allow continuous range to further expand the range | ||||||||
| list( | ||||||||
| continuous_range_coord = range( | ||||||||
| c(limit_info_discrete$continuous_range_coord, limit_info_continuous$continuous_range_coord) | ||||||||
| ), | ||||||||
| continuous_range = range( | ||||||||
| c(limit_info_discrete$continuous_range, limit_info_continuous$continuous_range) | ||||||||
| ) | ||||||||
| ) | ||||||||
| } | ||||||||
| } | ||||||||
| 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 layout in | ||||||||
| #' any way. In the gtable model, grobs always fill up the complete table | ||||||||
| #' cell. If you want custom justification you might need to define the grob | ||||||||
| #' dimension in absolute units, or put it into another gtable that can then be | ||||||||
| #' added to the gtable instead of the grob. | ||||||||
| #' | ||||||||
| #' @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. | ||||||||
| #' | ||||||||
| #' @return A gtable object with the new grob(s) added | ||||||||
| #' | ||||||||
| #' @family gtable manipulation | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' library(grid) | ||||||||
| #' | ||||||||
| #' gt <- gtable(widths = unit(c(1, 1), 'null'), heights = unit(c(1, 1), 'null')) | ||||||||
| #' pts <- pointsGrob(x = runif(5), y = runif(5)) | ||||||||
| #' | ||||||||
| #' # Add a grob to a single cell (top-right cell) | ||||||||
| #' gt <- gtable_add_grob(gt, pts, t = 1, l = 2) | ||||||||
| #' | ||||||||
| #' # Add a grob spanning multiple cells | ||||||||
| #' gt <- gtable_add_grob(gt, pts, t = 1, l = 1, b = 2) | ||||||||
| #' | ||||||||
| #' plot(gt) | ||||||||
| #' | ||||||||
| 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) | ||||||||
| if (is.logical(clip)) { | ||||||||
| clip <- ifelse(clip, "on", "off") | ||||||||
| } | ||||||||
| 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 | ||||||||
| } | ||||||||
| scales/R/scale-continuous.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Continuous scale | ||||||||
| #' | ||||||||
| #' @param x vector of continuous values to scale | ||||||||
| #' @param palette palette to use. | ||||||||
| #' | ||||||||
| #' Built in palettes: | ||||||||
| #' \Sexpr[results=rd,stage=build]{scales:::seealso_pal()} | ||||||||
| #' @param na.value value to use for missing values | ||||||||
| #' @param trans transformation object describing the how to transform the | ||||||||
| #' raw data prior to scaling. Defaults to the identity transformation which | ||||||||
| #' leaves the data unchanged. | ||||||||
| #' | ||||||||
| #' Built in transformations: | ||||||||
| #' \Sexpr[results=rd,stage=build]{scales:::seealso_trans()}. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' with(mtcars, plot(disp, mpg, cex = cscale(hp, rescale_pal()))) | ||||||||
| #' with(mtcars, plot(disp, mpg, cex = cscale(hp, rescale_pal(), | ||||||||
| #' trans = sqrt_trans()))) | ||||||||
| #' with(mtcars, plot(disp, mpg, cex = cscale(hp, area_pal()))) | ||||||||
| #' with(mtcars, plot(disp, mpg, pch = 20, cex = 5, | ||||||||
| #' col = cscale(hp, seq_gradient_pal("grey80", "black")))) | ||||||||
| cscale <- function(x, palette, na.value = NA_real_, trans = identity_trans()) { | ||||||||
| stopifnot(is.trans(trans)) | ||||||||
| x <- trans$transform(x) | ||||||||
| limits <- train_continuous(x) | ||||||||
| map_continuous(palette, x, limits, na.value) | ||||||||
| } | ||||||||
| #' Train (update) a continuous scale | ||||||||
| #' | ||||||||
| #' Strips attributes and always returns a numeric vector | ||||||||
| #' | ||||||||
| #' @inheritParams train_discrete | ||||||||
| #' @export | ||||||||
| train_continuous <- function(new, existing = NULL) { | ||||||||
| if (is.null(new)) return(existing) | ||||||||
| if (is.factor(new) || !typeof(new) %in% c("integer", "double")) { | ||||||||
| stop("Discrete value supplied to continuous scale", call. = FALSE) | ||||||||
| } | ||||||||
| suppressWarnings(range(existing, new, na.rm = TRUE, finite = TRUE)) | ||||||||
| } | ||||||||
| # Map values for a continuous palette. | ||||||||
| # | ||||||||
| # @param oob out of bounds behaviour. Defaults to \code{\link{censor}} | ||||||||
| # which turns oob values into missing values. | ||||||||
| map_continuous <- function(palette, x, limits, na.value = NA_real_, oob = censor) { | ||||||||
| x <- oob(rescale(x, from = limits)) | ||||||||
| pal <- palette(x) | ||||||||
| ifelse(!is.na(x), pal, na.value) | ||||||||
| } | ||||||||
| ggplot2/R/range.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Mutable ranges have a two methods (`train` and `reset`), and make | ||||||||
| #' it possible to build up complete ranges with multiple passes. | ||||||||
| #' | ||||||||
| #' These range objects should be instantiated with | ||||||||
| #' [continuous_range()] and [discrete_range()]. | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| Range <- ggproto("Range", NULL, | ||||||||
| range = NULL, | ||||||||
| reset = function(self) { | ||||||||
| self$range <- NULL | ||||||||
| } | ||||||||
| ) | ||||||||
| RangeDiscrete <- ggproto("RangeDiscrete", Range, | ||||||||
| train = function(self, x, drop = FALSE, na.rm = FALSE) { | ||||||||
| self$range <- scales::train_discrete(x, self$range, drop = drop, na.rm = na.rm) | ||||||||
| } | ||||||||
| ) | ||||||||
| RangeContinuous <- ggproto("RangeContinuous", Range, | ||||||||
| train = function(self, x) { | ||||||||
| self$range <- scales::train_continuous(x, self$range) | ||||||||
| } | ||||||||
| ) | ||||||||
| continuous_range <- function() { | ||||||||
| ggproto(NULL, RangeContinuous) | ||||||||
| } | ||||||||
| discrete_range <- function() { | ||||||||
| ggproto(NULL, RangeDiscrete) | ||||||||
| } | ||||||||
| ggplot2/R/grob-null.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' The zero grob draws nothing and has zero size. | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| zeroGrob <- function() .zeroGrob | ||||||||
| # Will get assigned in .onLoad() | ||||||||
| .zeroGrob <- 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") | ||||||||
| scales/R/minor_breaks.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Minor breaks | ||||||||
| #' | ||||||||
| #' Generate minor breaks between major breaks either spaced with a fixed width, | ||||||||
| #' or having a fixed number. | ||||||||
| #' | ||||||||
| #' @inheritParams breaks_width | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' demo_log10(c(1, 1e6)) | ||||||||
| #' if (FALSE) { | ||||||||
| #' # Requires https://github.com/tidyverse/ggplot2/pull/3591 | ||||||||
| #' demo_log10(c(1, 1e6), minor_breaks = minor_breaks_n(10)) | ||||||||
| #' } | ||||||||
| minor_breaks_width <- function(width, offset) { | ||||||||
| # Check that has needed version of ggplot2 | ||||||||
| f <- breaks_width(width, offset) | ||||||||
| function(range, breaks) { | ||||||||
| loop_breaks(range, breaks, f) | ||||||||
| } | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @param n number of breaks | ||||||||
| #' @rdname minor_breaks_width | ||||||||
| minor_breaks_n <- function(n) { | ||||||||
| # Check that has needed version of ggplot2 | ||||||||
| force(n) | ||||||||
| f <- function(rng) seq(rng[1], rng[2], length = n) | ||||||||
| function(range, breaks) { | ||||||||
| loop_breaks(range, breaks, f) | ||||||||
| } | ||||||||
| } | ||||||||
| loop_breaks <- function(range, breaks, f) { | ||||||||
| n <- length(breaks) | ||||||||
| out <- vector("list", n + 1) | ||||||||
| out[[1]] <- f(c(range[[1]], breaks[[1]])) | ||||||||
| for (i in seq2(2, n)) { | ||||||||
| out[[i]] <- f(breaks[c(i - 1L, i)]) | ||||||||
| } | ||||||||
| out[[n + 1]] <- f(c(breaks[[n]], range[[2]])) | ||||||||
| unique(unlist(out)) | ||||||||
| } | ||||||||
| # old interface ----------------------------------------------------------- | ||||||||
| #' Minor breaks | ||||||||
| #' | ||||||||
| #' Places minor breaks between major breaks. | ||||||||
| #' | ||||||||
| #' @param reverse if TRUE, calculates the minor breaks for a reversed scale | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' m <- extended_breaks()(c(1, 10)) | ||||||||
| #' regular_minor_breaks()(m, c(1, 10), n = 2) | ||||||||
| #' | ||||||||
| #' n <- extended_breaks()(c(0, -9)) | ||||||||
| #' regular_minor_breaks(reverse = TRUE)(n, c(0, -9), n = 2) | ||||||||
| regular_minor_breaks <- function(reverse = FALSE) { | ||||||||
| function(b, limits, n) { | ||||||||
| b <- b[!is.na(b)] | ||||||||
| if (length(b) < 2) return() | ||||||||
| bd <- diff(b)[1] | ||||||||
| # Allow minor breaks to extend outside major breaks towards limits | ||||||||
| if (!reverse) { | ||||||||
| if (min(limits) < min(b)) b <- c(b[1] - bd, b) | ||||||||
| if (max(limits) > max(b)) b <- c(b, b[length(b)] + bd) | ||||||||
| } else { | ||||||||
| if (max(limits) > max(b)) b <- c(b[1] - bd, b) | ||||||||
| if (min(limits) < min(b)) b <- c(b, b[length(b)] + bd) | ||||||||
| } | ||||||||
| # Find minor breaks between major breaks | ||||||||
| seq_between <- function(a, b) { | ||||||||
| seq(a, b, length.out = n + 1)[-(n + 1)] | ||||||||
| } | ||||||||
| breaks <- unlist(Map(seq_between, b[-length(b)], b[-1])) | ||||||||
| # Add the final break back | ||||||||
| breaks <- c(breaks, b[length(b)]) | ||||||||
| breaks | ||||||||
| } | ||||||||
| } | ||||||||
| 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(y) == 0) return(x) | ||||||||
| if (length(x) == 0) return(y) | ||||||||
| if (getRversion() >= "3.6" && (is.list(x) || is.list(y))) { | ||||||||
| if (identical(comp, pmin)) { | ||||||||
| return(unit.pmin(x, y)) | ||||||||
| } | ||||||||
| if (identical(comp, pmax)) { | ||||||||
| return(unit.pmax(x, y)) | ||||||||
| } | ||||||||
| stop('Comparison not supported', call. = FALSE) | ||||||||
| } | ||||||||
| # Below should be removed once the old grid unit implementation has been deprecated | ||||||||
| x_attr <- attributes(x) | ||||||||
| x_val <- unclass(x) | ||||||||
| y_val <- unclass(y) | ||||||||
| x_unit <- x_attr$unit | ||||||||
| y_unit <- attr(x, "unit") | ||||||||
| if (!all(x_unit == y_unit)) { | ||||||||
| stop("Comparison of units with different types currently not supported") | ||||||||
| } | ||||||||
| `attributes<-`(comp(x_val, y_val), x_attr) | ||||||||
| } | ||||||||
| 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/add-rows-cols.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Add new rows in specified position. | ||||||||
| #' | ||||||||
| #' Insert new rows in a gtable and adjust the grob placement accordingly. If | ||||||||
| #' rows are added in the middle of a grob spanning multiple rows, the grob will | ||||||||
| #' continue to span them all. If a row is added above or below a grob, the grob | ||||||||
| #' will not span the new row(s). | ||||||||
| #' | ||||||||
| #' @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. | ||||||||
| #' | ||||||||
| #' @return A gtable with the new rows added. | ||||||||
| #' | ||||||||
| #' @family gtable manipulation | ||||||||
| #' | ||||||||
| #' @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. | ||||||||
| #' | ||||||||
| #' Insert new columns in a gtable and adjust the grob placement accordingly. If | ||||||||
| #' columns are added in the middle of a grob spanning multiple columns, the grob | ||||||||
| #' will continue to span them all. If a column is added to the left or right of | ||||||||
| #' a grob, the grob will not span the new column(s). | ||||||||
| #' | ||||||||
| #' @param x a [gtable()] object | ||||||||
| #' @param widths a unit vector giving the widths of the new columns | ||||||||
| #' @param pos new columns will be added to the right of this position. Defaults | ||||||||
| #' to adding col on right. `0` adds on the left. | ||||||||
| #' | ||||||||
| #' @return A gtable with the new columns added. | ||||||||
| #' | ||||||||
| #' @family gtable manipulation | ||||||||
| #' | ||||||||
| #' @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 | ||||||||
| } | ||||||||
| gtable/R/add-space.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Add row/column spacing. | ||||||||
| #' | ||||||||
| #' Adds `width` space between the columns or `height` space between | ||||||||
| #' the rows, effictvely pushing the existing cells apart. | ||||||||
| #' | ||||||||
| #' @name gtable_add_space | ||||||||
| #' @param x a gtable object | ||||||||
| #' | ||||||||
| #' @return A gtable with the additional rows or columns added | ||||||||
| #' | ||||||||
| #' @family gtable manipulation | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' library(grid) | ||||||||
| #' | ||||||||
| #' rect <- rectGrob() | ||||||||
| #' rect_mat <- matrix(rep(list(rect), 9), nrow = 3) | ||||||||
| #' | ||||||||
| #' gt <- gtable_matrix("rects", rect_mat, widths = unit(rep(1, 3), "null"), | ||||||||
| #' heights = unit(rep(1, 3), "null")) | ||||||||
| #' | ||||||||
| #' plot(gt) | ||||||||
| #' | ||||||||
| #' # Add spacing between the grobs | ||||||||
| #' # same height between all rows | ||||||||
| #' gt <- gtable_add_row_space(gt, unit(0.5, "cm")) | ||||||||
| #' | ||||||||
| #' # Different width between the columns | ||||||||
| #' gt <- gtable_add_col_space(gt, unit(c(0.5, 1), "cm")) | ||||||||
| #' | ||||||||
| #' plot(gt) | ||||||||
| 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 | ||||||||
| } | ||||||||
| gtable/R/grid.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Visualise the layout of a gtable. | ||||||||
| #' | ||||||||
| #' This function is a simple wrapper around [grid::grid.show.layout()] that | ||||||||
| #' allows you to inspect the layout of the gtable. | ||||||||
| #' | ||||||||
| #' @param x a gtable object | ||||||||
| #' @inheritDotParams grid::grid.show.layout | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' gt <- gtable(widths = grid::unit(c(1, 0.5, 2), c("null", "cm", "null")), | ||||||||
| #' heights = grid::unit(c(0.2, 1, 3), c("inch", "null", "cm"))) | ||||||||
| #' gtable_show_layout(gt) | ||||||||
| #' | ||||||||
| 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 | ||||||||
| } | ||||||||
| 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() | ||||||||
| } | ||||||||
| scales/R/bounds.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Rescale continuous vector to have specified minimum and maximum | ||||||||
| #' | ||||||||
| #' @param x continuous vector of values to manipulate. | ||||||||
| #' @param to output range (numeric vector of length two) | ||||||||
| #' @param from input range (vector of length two). If not given, is | ||||||||
| #' calculated from the range of `x` | ||||||||
| #' @param ... other arguments passed on to methods | ||||||||
| #' @keywords manip | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' rescale(1:100) | ||||||||
| #' rescale(runif(50)) | ||||||||
| #' rescale(1) | ||||||||
| rescale <- function(x, to, from, ...) { | ||||||||
| UseMethod("rescale") | ||||||||
| } | ||||||||
| #' @rdname rescale | ||||||||
| #' @export | ||||||||
| rescale.numeric <- function(x, to = c(0, 1), from = range(x, na.rm = TRUE, finite = TRUE), ...) { | ||||||||
| if (zero_range(from) || zero_range(to)) { | ||||||||
| return(ifelse(is.na(x), NA, mean(to))) | ||||||||
| } | ||||||||
| (x - from[1]) / diff(from) * diff(to) + to[1] | ||||||||
| } | ||||||||
| #' @export | ||||||||
| rescale.NULL <- function(...) NULL | ||||||||
| #' @rdname rescale | ||||||||
| #' @export | ||||||||
| rescale.dist <- rescale.numeric | ||||||||
| #' @rdname rescale | ||||||||
| #' @export | ||||||||
| rescale.logical <- rescale.numeric | ||||||||
| #' @rdname rescale | ||||||||
| #' @export | ||||||||
| rescale.POSIXt <- function(x, to = c(0, 1), from = range(x, na.rm = TRUE, finite = TRUE), ...) { | ||||||||
| x <- as.numeric(x) | ||||||||
| from <- as.numeric(from) | ||||||||
| rescale.numeric(x = x, to = to, from = from) | ||||||||
| } | ||||||||
| #' @rdname rescale | ||||||||
| #' @export | ||||||||
| rescale.Date <- rescale.POSIXt | ||||||||
| #' @rdname rescale | ||||||||
| #' @export | ||||||||
| rescale.integer64 <- function(x, to = c(0, 1), from = range(x, na.rm = TRUE), ...) { | ||||||||
| if (zero_range(from, tol = 0) || zero_range(to)) { | ||||||||
| return(ifelse(is.na(x), NA, mean(to))) | ||||||||
| } | ||||||||
| (x - from[1]) / diff(from) * diff(to) + to[1] | ||||||||
| } | ||||||||
| #' Rescale vector to have specified minimum, midpoint, and maximum | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @param x vector of values to manipulate. | ||||||||
| #' @param to output range (numeric vector of length two) | ||||||||
| #' @param from input range (vector of length two). If not given, is | ||||||||
| #' calculated from the range of `x` | ||||||||
| #' @param mid mid-point of input range | ||||||||
| #' @param ... other arguments passed on to methods | ||||||||
| #' @examples | ||||||||
| #' rescale_mid(1:100, mid = 50.5) | ||||||||
| #' rescale_mid(runif(50), mid = 0.5) | ||||||||
| #' rescale_mid(1) | ||||||||
| rescale_mid <- function(x, to, from, mid, ...) { | ||||||||
| UseMethod("rescale_mid") | ||||||||
| } | ||||||||
| #' @rdname rescale_mid | ||||||||
| #' @export | ||||||||
| rescale_mid.numeric <- function(x, to = c(0, 1), from = range(x, na.rm = TRUE), mid = 0, ...) { | ||||||||
| if (zero_range(from) || zero_range(to)) { | ||||||||
| return(ifelse(is.na(x), NA, mean(to))) | ||||||||
| } | ||||||||
| extent <- 2 * max(abs(from - mid)) | ||||||||
| (x - mid) / extent * diff(to) + mean(to) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| rescale_mid.NULL <- function(...) NULL | ||||||||
| #' @rdname rescale_mid | ||||||||
| #' @export | ||||||||
| rescale_mid.logical <- rescale_mid.numeric | ||||||||
| #' @rdname rescale_mid | ||||||||
| #' @export | ||||||||
| rescale_mid.dist <- rescale_mid.numeric | ||||||||
| #' @rdname rescale_mid | ||||||||
| #' @export | ||||||||
| rescale_mid.POSIXt <- function(x, to = c(0, 1), from = range(x, na.rm = TRUE), | ||||||||
| mid, ...) { | ||||||||
| x <- as.numeric(as.POSIXct(x)) | ||||||||
| if (!is.numeric(from)) { | ||||||||
| from <- as.numeric(as.POSIXct(from)) | ||||||||
| } | ||||||||
| if (!is.numeric(mid)) { | ||||||||
| mid <- as.numeric(as.POSIXct(mid)) | ||||||||
| } | ||||||||
| rescale_mid.numeric(x = x, to = to, from = from, mid = mid) | ||||||||
| } | ||||||||
| #' @rdname rescale_mid | ||||||||
| #' @export | ||||||||
| rescale_mid.Date <- rescale_mid.POSIXt | ||||||||
| #' @rdname rescale_mid | ||||||||
| #' @export | ||||||||
| rescale_mid.integer64 <- function(x, to = c(0, 1), from = range(x, na.rm = TRUE), mid = 0, ...) { | ||||||||
| if (zero_range(from, tol = 0) || zero_range(to)) { | ||||||||
| return(ifelse(is.na(x), NA, mean(to))) | ||||||||
| } | ||||||||
| extent <- 2 * max(abs(from - mid)) | ||||||||
| (x - mid) / extent * diff(to) + mean(to) | ||||||||
| } | ||||||||
| #' Rescale numeric vector to have specified maximum | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @param x numeric vector of values to manipulate. | ||||||||
| #' @param to output range (numeric vector of length two) | ||||||||
| #' @param from input range (numeric vector of length two). If not given, is | ||||||||
| #' calculated from the range of `x` | ||||||||
| #' @examples | ||||||||
| #' rescale_max(1:100) | ||||||||
| #' rescale_max(runif(50)) | ||||||||
| #' rescale_max(1) | ||||||||
| rescale_max <- function(x, to = c(0, 1), from = range(x, na.rm = TRUE)) { | ||||||||
| x / from[2] * to[2] | ||||||||
| } | ||||||||
| #' Don't perform rescaling | ||||||||
| #' | ||||||||
| #' @param x numeric vector of values to manipulate. | ||||||||
| #' @param ... all other arguments ignored | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' rescale_none(1:100) | ||||||||
| rescale_none <- function(x, ...) { | ||||||||
| x | ||||||||
| } | ||||||||
| #' Out of bounds handling | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' This set of functions modify data values outside a given range. | ||||||||
| #' The `oob_*()` functions are designed to be passed as the `oob` argument of | ||||||||
| #' ggplot2 continuous and binned scales, with `oob_discard` being an exception. | ||||||||
| #' | ||||||||
| #' These functions affect out of bounds values in the following ways: | ||||||||
| #' | ||||||||
| #' * `oob_censor()` replaces out of bounds values with `NA`s. This is the | ||||||||
| #' default `oob` argument for continuous scales. | ||||||||
| #' * `oob_censor_any()` acts like `oob_censor()`, but also replaces infinite | ||||||||
| #' values with `NA`s. | ||||||||
| #' * `oob_squish()` replaces out of bounds values with the nearest limit. This | ||||||||
| #' is the default `oob` argument for binned scales. | ||||||||
| #' * `oob_squish_any()` acts like `oob_squish()`, but also replaces infinite | ||||||||
| #' values with the nearest limit. | ||||||||
| #' * `oob_squish_infinite()` only replaces infinite values by the nearest limit. | ||||||||
| #' * `oob_keep()` does not adjust out of bounds values. In position scales, | ||||||||
| #' behaves as zooming limits without data removal. | ||||||||
| #' * `oob_discard()` removes out of bounds values from the input. Not suitable | ||||||||
| #' for ggplot2 scales. | ||||||||
| #' | ||||||||
| #' @param x A numeric vector of values to modify. | ||||||||
| #' @param range A numeric vector of length two giving the minimum and maximum | ||||||||
| #' limit of the desired output range respectively. | ||||||||
| #' @param only.finite A logical of length one. When `TRUE`, only finite values | ||||||||
| #' are altered. When `FALSE`, also infinite values are altered. | ||||||||
| #' | ||||||||
| #' @return Most `oob_()` functions return a vector of numerical values of the | ||||||||
| #' same length as the `x` argument, wherein out of bounds values have been | ||||||||
| #' modified. Only `oob_discard()` returns a vector of less than or of equal | ||||||||
| #' length to the `x` argument. | ||||||||
| #' | ||||||||
| #' @details The `oob_censor_any()` and `oob_squish_any()` functions are the same | ||||||||
| #' as `oob_censor()` and `oob_squish()` with the `only.finite` argument set to | ||||||||
| #' `FALSE`. | ||||||||
| #' | ||||||||
| #' Replacing position values with `NA`s, as `oob_censor()` does, will typically | ||||||||
| #' lead to removal of those datapoints in ggplot. | ||||||||
| #' | ||||||||
| #' Setting ggplot coordinate limits is equivalent to using `oob_keep()` in | ||||||||
| #' position scales. | ||||||||
| #' | ||||||||
| #' @section Old interface: `censor()`, `squish()`, `squish_infinite()` and | ||||||||
| #' `discard()` are no longer recommended; please use `oob_censor()`, | ||||||||
| #' `oob_squish()`, `oob_squish_infinite()` and `oob_discard()` instead. | ||||||||
| #' | ||||||||
| #' @name oob | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Censoring replaces out of bounds values with NAs | ||||||||
| #' oob_censor(c(-Inf, -1, 0.5, 1, 2, NA, Inf)) | ||||||||
| #' oob_censor_any(c(-Inf, -1, 0.5, 1, 2, NA, Inf)) | ||||||||
| #' | ||||||||
| #' # Squishing replaces out of bounds values with the nearest range limit | ||||||||
| #' oob_squish(c(-Inf, -1, 0.5, 1, 2, NA, Inf)) | ||||||||
| #' oob_squish_any(c(-Inf, -1, 0.5, 1, 2, NA, Inf)) | ||||||||
| #' oob_squish_infinite(c(-Inf, -1, 0.5, 1, 2, NA, Inf)) | ||||||||
| #' | ||||||||
| #' # Keeping does not alter values | ||||||||
| #' oob_keep(c(-Inf, -1, 0.5, 1, 2, NA, Inf)) | ||||||||
| #' | ||||||||
| #' # Discarding will remove out of bounds values | ||||||||
| #' oob_discard(c(-Inf, -1, 0.5, 1, 2, NA, Inf)) | ||||||||
| NULL | ||||||||
| #' @rdname oob | ||||||||
| #' @export | ||||||||
| oob_censor <- function(x, range = c(0, 1), only.finite = TRUE) { | ||||||||
| force(range) | ||||||||
| finite <- if (only.finite) is.finite(x) else TRUE | ||||||||
| x[finite & x < range[1]] <- NA_real_ | ||||||||
| x[finite & x > range[2]] <- NA_real_ | ||||||||
| x | ||||||||
| } | ||||||||
| #' @rdname oob | ||||||||
| #' @export | ||||||||
| oob_censor_any <- function(x, range = c(0, 1)) { | ||||||||
| oob_censor(x, range = range, only.finite = FALSE) | ||||||||
| } | ||||||||
| #' @rdname oob | ||||||||
| #' @export | ||||||||
| oob_discard <- function(x, range = c(0, 1)) { | ||||||||
| force(range) | ||||||||
| x[x >= range[1] & x <= range[2]] | ||||||||
| } | ||||||||
| #' @rdname oob | ||||||||
| #' @author `oob_squish()`: Homer Strong <homer.strong@@gmail.com> | ||||||||
| #' @export | ||||||||
| oob_squish <- function(x, range = c(0, 1), only.finite = TRUE) { | ||||||||
| force(range) | ||||||||
| finite <- if (only.finite) is.finite(x) else TRUE | ||||||||
| x[finite & x < range[1]] <- range[1] | ||||||||
| x[finite & x > range[2]] <- range[2] | ||||||||
| x | ||||||||
| } | ||||||||
| #' @rdname oob | ||||||||
| #' @export | ||||||||
| oob_squish_any <- function(x, range = c(0, 1)) { | ||||||||
| oob_squish(x, range, only.finite = FALSE) | ||||||||
| } | ||||||||
| #' @rdname oob | ||||||||
| #' @export | ||||||||
| oob_squish_infinite <- function(x, range = c(0, 1)) { | ||||||||
| force(range) | ||||||||
| x[x == -Inf] <- range[1] | ||||||||
| x[x == Inf] <- range[2] | ||||||||
| x | ||||||||
| } | ||||||||
| #' @rdname oob | ||||||||
| #' @export | ||||||||
| oob_keep <- function(x, range = c(0, 1)) { | ||||||||
| x | ||||||||
| } | ||||||||
| #' @rdname oob | ||||||||
| #' @export | ||||||||
| censor <- oob_censor | ||||||||
| #' @rdname oob | ||||||||
| #' @export | ||||||||
| discard <- oob_discard | ||||||||
| #' @rdname oob | ||||||||
| #' @export | ||||||||
| squish <- oob_squish | ||||||||
| #' @rdname oob | ||||||||
| #' @export | ||||||||
| squish_infinite <- oob_squish_infinite | ||||||||
| #' Expand a range with a multiplicative or additive constant | ||||||||
| #' | ||||||||
| #' @param range range of data, numeric vector of length 2 | ||||||||
| #' @param mul multiplicative constant | ||||||||
| #' @param add additive constant | ||||||||
| #' @param zero_width distance to use if range has zero width | ||||||||
| #' @export | ||||||||
| expand_range <- function(range, mul = 0, add = 0, zero_width = 1) { | ||||||||
| if (is.null(range)) return() | ||||||||
| width <- if (zero_range(range)) zero_width else diff(range) | ||||||||
| range + c(-1, 1) * (width * mul + add) | ||||||||
| } | ||||||||
| #' Determine if range of vector is close to zero, with a specified tolerance | ||||||||
| #' | ||||||||
| #' The machine epsilon is the difference between 1.0 and the next number | ||||||||
| #' that can be represented by the machine. By default, this function | ||||||||
| #' uses epsilon * 1000 as the tolerance. First it scales the values so that | ||||||||
| #' they have a mean of 1, and then it checks if the difference between | ||||||||
| #' them is larger than the tolerance. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' eps <- .Machine$double.eps | ||||||||
| #' zero_range(c(1, 1 + eps)) # TRUE | ||||||||
| #' zero_range(c(1, 1 + 99 * eps)) # TRUE | ||||||||
| #' zero_range(c(1, 1 + 1001 * eps)) # FALSE - Crossed the tol threshold | ||||||||
| #' zero_range(c(1, 1 + 2 * eps), tol = eps) # FALSE - Changed tol | ||||||||
| #' | ||||||||
| #' # Scaling up or down all the values has no effect since the values | ||||||||
| #' # are rescaled to 1 before checking against tol | ||||||||
| #' zero_range(100000 * c(1, 1 + eps)) # TRUE | ||||||||
| #' zero_range(100000 * c(1, 1 + 1001 * eps)) # FALSE | ||||||||
| #' zero_range(.00001 * c(1, 1 + eps)) # TRUE | ||||||||
| #' zero_range(.00001 * c(1, 1 + 1001 * eps)) # FALSE | ||||||||
| #' | ||||||||
| #' # NA values | ||||||||
| #' zero_range(c(1, NA)) # NA | ||||||||
| #' zero_range(c(1, NaN)) # NA | ||||||||
| #' | ||||||||
| #' # Infinite values | ||||||||
| #' zero_range(c(1, Inf)) # FALSE | ||||||||
| #' zero_range(c(-Inf, Inf)) # FALSE | ||||||||
| #' zero_range(c(Inf, Inf)) # TRUE | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @param x numeric range: vector of length 2 | ||||||||
| #' @param tol A value specifying the tolerance. | ||||||||
| #' @return logical `TRUE` if the relative difference of the endpoints of | ||||||||
| #' the range are not distinguishable from 0. | ||||||||
| zero_range <- function(x, tol = 1000 * .Machine$double.eps) { | ||||||||
| if (length(x) == 1) return(TRUE) | ||||||||
| if (length(x) != 2) stop("x must be length 1 or 2") | ||||||||
| if (any(is.na(x))) return(NA) | ||||||||
| # Special case: if they are equal as determined by ==, then there | ||||||||
| # is zero range. Also handles (Inf, Inf) and (-Inf, -Inf) | ||||||||
| if (x[1] == x[2]) return(TRUE) | ||||||||
| # If we reach this, then x must be (-Inf, Inf) or (Inf, -Inf) | ||||||||
| if (all(is.infinite(x))) return(FALSE) | ||||||||
| # Take the smaller (in magnitude) value of x, and use it as the scaling | ||||||||
| # factor. | ||||||||
| m <- min(abs(x)) | ||||||||
| # If we get here, then exactly one of the x's is 0. Return FALSE | ||||||||
| if (m == 0) return(FALSE) | ||||||||
| # If x[1] - x[2] (scaled to 1) is smaller than tol, then return | ||||||||
| # TRUE; otherwise return FALSE | ||||||||
| abs((x[1] - x[2]) / m) < tol | ||||||||
| } | ||||||||
| digest/R/digest.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| ## digest -- hash digest functions for R | ||||||||
| ## | ||||||||
| ## Copyright (C) 2003 - 2019 Dirk Eddelbuettel <edd@debian.org> | ||||||||
| ## Copyright (C) 2009 - 2019 Henrik Bengtsson | ||||||||
| ## Copyright (C) 2012 - 2019 Hannes Muehleisen | ||||||||
| ## Copyright (C) 2014 - 2019 Jim Hester | ||||||||
| ## Copyright (C) 2019 Kendon Bell | ||||||||
| ## Copyright (C) 2019 Matthew de Queljoe | ||||||||
| ## | ||||||||
| ## This file is part of digest. | ||||||||
| ## | ||||||||
| ## digest is free software: you can redistribute it and/or modify | ||||||||
| ## it under the terms of the GNU General Public License as published by | ||||||||
| ## the Free Software Foundation, either version 2 of the License, or | ||||||||
| ## (at your option) any later version. | ||||||||
| ## | ||||||||
| ## digest is distributed in the hope that it will be useful, | ||||||||
| ## but WITHOUT ANY WARRANTY; without even the implied warranty of | ||||||||
| ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||||||||
| ## GNU General Public License for more details. | ||||||||
| ## | ||||||||
| ## You should have received a copy of the GNU General Public License | ||||||||
| ## along with digest. If not, see <http://www.gnu.org/licenses/>. | ||||||||
| digest <- function(object, algo=c("md5", "sha1", "crc32", "sha256", "sha512", | ||||||||
| "xxhash32", "xxhash64", "murmur32", | ||||||||
| "spookyhash", "blake3"), | ||||||||
| serialize=TRUE, | ||||||||
| file=FALSE, | ||||||||
| length=Inf, | ||||||||
| skip="auto", | ||||||||
| ascii=FALSE, | ||||||||
| raw=FALSE, | ||||||||
| seed=0, | ||||||||
| errormode=c("stop","warn","silent"), | ||||||||
| serializeVersion=.getSerializeVersion()) { | ||||||||
| # Explicitly specify choices; this is much faster than having match.arg() | ||||||||
| # infer them from the function's formals. | ||||||||
| algo <- match.arg(algo, c("md5", "sha1", "crc32", "sha256", "sha512", | ||||||||
| "xxhash32", "xxhash64", "murmur32", | ||||||||
| "spookyhash", "blake3")) | ||||||||
| errormode <- match.arg(errormode, c("stop", "warn", "silent")) | ||||||||
| if (is.infinite(length)) { | ||||||||
| length <- -1 # internally we use -1 for infinite len | ||||||||
| } | ||||||||
| if (is.character(file) && missing(object)) { | ||||||||
| object <- file # nocov | ||||||||
| file <- TRUE # nocov | ||||||||
| } | ||||||||
| is_streaming_algo <- algo == "spookyhash" | ||||||||
| if (is_streaming_algo && !serialize) { | ||||||||
| .errorhandler(paste0(algo, " algorithm is not available without serialization."), # #nocov | ||||||||
| mode=errormode) # #nocov | ||||||||
| } | ||||||||
| if (serialize && !file) { | ||||||||
| if (!is_streaming_algo) { | ||||||||
| ## support the 'nosharing' option in pqR's serialize() | ||||||||
| object <- if (.hasNoSharing()) | ||||||||
| serialize (object, connection=NULL, ascii=ascii, | ||||||||
| nosharing=TRUE, version=serializeVersion) | ||||||||
| else | ||||||||
| serialize (object, connection=NULL, ascii=ascii, | ||||||||
| version=serializeVersion) | ||||||||
| } | ||||||||
| ## we support raw vectors, so no mangling of 'object' is necessary | ||||||||
| ## regardless of R version | ||||||||
| ## skip="auto" - skips the serialization header [SU] | ||||||||
| if (is.character(skip) && skip == "auto") | ||||||||
| skip <- set_skip(object, ascii) | ||||||||
| } else if (!is.character(object) && !inherits(object,"raw") && | ||||||||
| !is_streaming_algo) { | ||||||||
| return(.errorhandler(paste("Argument object must be of type character", # #nocov | ||||||||
| "or raw vector if serialize is FALSE"), mode=errormode)) # #nocov | ||||||||
| } | ||||||||
| if (file && !is.character(object)) | ||||||||
| return(.errorhandler("file=TRUE can only be used with a character object", # #nocov | ||||||||
| mode=errormode)) # #nocov | ||||||||
| if (file && is_streaming_algo) | ||||||||
| return(.errorhandler(paste0(algo, " algorithm can not be used with files."), # #nocov | ||||||||
| mode=errormode)) # #nocov | ||||||||
| ## HB 14 Mar 2007: null op, only turned to char if alreadt char | ||||||||
| ##if (!inherits(object,"raw")) | ||||||||
| ## object <- as.character(object) | ||||||||
| algoint <- algo_int(algo) | ||||||||
| if (file) { | ||||||||
| algoint <- algoint+100 | ||||||||
| object <- path.expand(object) | ||||||||
| if (.isWindows()) object <- enc2utf8(object) | ||||||||
| check_file(object, errormode) | ||||||||
| } | ||||||||
| ## if skip is auto (or any other text for that matter), we just turn it | ||||||||
| ## into 0 because auto should have been converted into a number earlier | ||||||||
| ## if it was valid [SU] | ||||||||
| if (is.character(skip)) skip <- 0 | ||||||||
| if (!is_streaming_algo) { | ||||||||
| val <- .Call(digest_impl, | ||||||||
| object, | ||||||||
| as.integer(algoint), | ||||||||
| as.integer(length), | ||||||||
| as.integer(skip), | ||||||||
| as.integer(raw), | ||||||||
| as.integer(seed)) | ||||||||
| } else if (algo == "spookyhash"){ | ||||||||
| # 0s are the seeds. They are included to enable testing against fastdigest. | ||||||||
| val <- paste(.Call(spookydigest_impl, object, skip, 0, 0, serializeVersion, NULL), collapse="") | ||||||||
| } | ||||||||
| ## crc32 output was not guaranteed to be eight chars long, which we corrected | ||||||||
| ## this allows to get the old behaviour back for compatibility | ||||||||
| if ((algoint == 3 || algoint == 103) && .getCRC32PreferOldOutput()) { | ||||||||
| val <- sub("^0+", "", val) | ||||||||
| } | ||||||||
| return(val) | ||||||||
| } | ||||||||
| ## utility functions used by digest() and getVDigest() below | ||||||||
| .errorhandler <- function(txt, obj="", mode="stop") { | ||||||||
| if (mode == "stop") { # nocov start | ||||||||
| stop(txt, obj, call.=FALSE) | ||||||||
| } else if (mode == "warn") { | ||||||||
| warning(txt, obj, call.=FALSE) | ||||||||
| return(invisible(NA)) | ||||||||
| } else { | ||||||||
| return(invisible(NULL)) # nocov end | ||||||||
| } | ||||||||
| } | ||||||||
| algo_int <- function(algo) | ||||||||
| switch( | ||||||||
| algo, | ||||||||
| md5 = 1, | ||||||||
| sha1 = 2, | ||||||||
| crc32 = 3, | ||||||||
| sha256 = 4, | ||||||||
| sha512 = 5, | ||||||||
| xxhash32 = 6, | ||||||||
| xxhash64 = 7, | ||||||||
| murmur32 = 8, | ||||||||
| spookyhash = 9, | ||||||||
| blake3 = 10 | ||||||||
| ) | ||||||||
| ## HB 14 Mar 2007: | ||||||||
| ## Exclude serialization header (non-data dependent bytes but R | ||||||||
| ## version specific). In ASCII, the header consists of for rows | ||||||||
| ## ending with a newline ('\n'). We need to skip these. | ||||||||
| ## The end of 4th row is *typically* within the first 18 bytes | ||||||||
| set_skip <- function(object, ascii){ | ||||||||
| if (!ascii) | ||||||||
| return(14) | ||||||||
| ## Was: skip <- if (ascii) 18 else 14 | ||||||||
| which(object[1:30] == as.raw(10))[4] # nocov | ||||||||
| } | ||||||||
| check_file <- function(object, errormode){ | ||||||||
| if (!file.exists(object)) { | ||||||||
| return(.errorhandler("The file does not exist: ", object, mode=errormode)) # nocov start | ||||||||
| } | ||||||||
| if (!isTRUE(!file.info(object)$isdir)) { | ||||||||
| return(.errorhandler("The specified pathname is not a file: ", | ||||||||
| object, mode=errormode)) | ||||||||
| } | ||||||||
| if (file.access(object, 4)) { | ||||||||
| return(.errorhandler("The specified file is not readable: ", | ||||||||
| object, mode=errormode)) # #nocov end | ||||||||
| } | ||||||||
| } | ||||||||
| ggplot2/R/compat-plyr.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Adds missing elements to a vector from a default vector | ||||||||
| #' | ||||||||
| #' This function appends a given named vector or list with additional elements | ||||||||
| #' from a default vector, only adding those that does not already exist in the | ||||||||
| #' first. | ||||||||
| #' | ||||||||
| #' @param x,y Named vectors or lists | ||||||||
| #' | ||||||||
| #' @return `x` with missing values from `y` appended | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @noRd | ||||||||
| #' | ||||||||
| defaults <- function(x, y) c(x, y[setdiff(names(y), names(x))]) | ||||||||
| # Remove rownames from data frames and matrices | ||||||||
| unrowname <- function(x) { | ||||||||
| if (is.data.frame(x)) { | ||||||||
| attr(x, "row.names") <- .set_row_names(.row_names_info(x, 2L)) | ||||||||
| } else if (is.matrix(x)) { | ||||||||
| dimnames(x)[1] <- list(NULL) | ||||||||
| } else { | ||||||||
| abort("Can only remove rownames from data.frame and matrix objects") | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| #' Rename elements in a list, data.frame or vector | ||||||||
| #' | ||||||||
| #' This is akin to `dplyr::rename` and `plyr::rename`. It renames elements given | ||||||||
| #' as names in the `replace` vector to the values in the `replace` vector | ||||||||
| #' without touching elements not referenced. | ||||||||
| #' | ||||||||
| #' @param x A data.frame or a named vector or list | ||||||||
| #' @param replace A named character vector. The names identifies the elements in | ||||||||
| #' `x` that should be renamed and the values gives the new names. | ||||||||
| #' | ||||||||
| #' @return `x`, with new names according to `replace` | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @noRd | ||||||||
| #' | ||||||||
| rename <- function(x, replace) { | ||||||||
| current_names <- names(x) | ||||||||
| old_names <- names(replace) | ||||||||
| missing_names <- setdiff(old_names, current_names) | ||||||||
| if (length(missing_names) > 0) { | ||||||||
| replace <- replace[!old_names %in% missing_names] | ||||||||
| old_names <- names(replace) | ||||||||
| } | ||||||||
| names(x)[match(old_names, current_names)] <- as.vector(replace) | ||||||||
| x | ||||||||
| } | ||||||||
| # Adapted from plyr:::id_vars | ||||||||
| # Create a unique id for elements in a single vector | ||||||||
| id_var <- function(x, drop = FALSE) { | ||||||||
| if (length(x) == 0) { | ||||||||
| id <- integer() | ||||||||
| n = 0L | ||||||||
| } else if (!is.null(attr(x, "n")) && !drop) { | ||||||||
| return(x) | ||||||||
| } else if (is.factor(x) && !drop) { | ||||||||
| x <- addNA(x, ifany = TRUE) | ||||||||
| id <- as.integer(x) | ||||||||
| n <- length(levels(x)) | ||||||||
| } else { | ||||||||
| levels <- sort(unique(x), na.last = TRUE) | ||||||||
| id <- match(x, levels) | ||||||||
| n <- max(id) | ||||||||
| } | ||||||||
| attr(id, "n") <- n | ||||||||
| id | ||||||||
| } | ||||||||
| #' Create an unique integer id for each unique row in a data.frame | ||||||||
| #' | ||||||||
| #' Properties: | ||||||||
| #' - `order(id)` is equivalent to `do.call(order, df)` | ||||||||
| #' - rows containing the same data have the same value | ||||||||
| #' - if `drop = FALSE` then room for all possibilites | ||||||||
| #' | ||||||||
| #' @param .variables list of variables | ||||||||
| #' @param drop Should unused factor levels be dropped? | ||||||||
| #' | ||||||||
| #' @return An integer vector with attribute `n` giving the total number of | ||||||||
| #' possible unique rows | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @noRd | ||||||||
| #' | ||||||||
| id <- function(.variables, drop = FALSE) { | ||||||||
| nrows <- NULL | ||||||||
| if (is.data.frame(.variables)) { | ||||||||
| nrows <- nrow(.variables) | ||||||||
| .variables <- unclass(.variables) | ||||||||
| } | ||||||||
| lengths <- vapply(.variables, length, integer(1)) | ||||||||
| .variables <- .variables[lengths != 0] | ||||||||
| if (length(.variables) == 0) { | ||||||||
| n <- nrows %||% 0L | ||||||||
| id <- seq_len(n) | ||||||||
| attr(id, "n") <- n | ||||||||
| return(id) | ||||||||
| } | ||||||||
| if (length(.variables) == 1) { | ||||||||
| return(id_var(.variables[[1]], drop = drop)) | ||||||||
| } | ||||||||
| ids <- rev(lapply(.variables, id_var, drop = drop)) | ||||||||
| p <- length(ids) | ||||||||
| ndistinct <- vapply(ids, attr, "n", FUN.VALUE = numeric(1), USE.NAMES = FALSE) | ||||||||
| n <- prod(ndistinct) | ||||||||
| if (n > 2^31) { | ||||||||
| char_id <- do.call("paste", c(ids, sep = "\r")) | ||||||||
| res <- match(char_id, unique(char_id)) | ||||||||
| } | ||||||||
| else { | ||||||||
| combs <- c(1, cumprod(ndistinct[-p])) | ||||||||
| mat <- do.call("cbind", ids) | ||||||||
| res <- c((mat - 1L) %*% combs + 1L) | ||||||||
| } | ||||||||
| if (drop) { | ||||||||
| id_var(res, drop = TRUE) | ||||||||
| } | ||||||||
| else { | ||||||||
| res <- as.integer(res) | ||||||||
| attr(res, "n") <- n | ||||||||
| res | ||||||||
| } | ||||||||
| } | ||||||||
| #' Count number of occurences for each unique combination of variables | ||||||||
| #' | ||||||||
| #' Each unique combination of the variables in `df` given by `vars` will be | ||||||||
| #' identified and their occurences counted. If `wt_var` is given the counts will | ||||||||
| #' be weighted by the values in this column. | ||||||||
| #' | ||||||||
| #' @param df A data.frame | ||||||||
| #' @param vars A vector of column names. If `NULL` all columns in `df` will be | ||||||||
| #' used | ||||||||
| #' @param wt_var The name of a column to use as weight | ||||||||
| #' | ||||||||
| #' @return A data.frame with the unique combinations counted along with a `n` | ||||||||
| #' column giving the counts | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @noRd | ||||||||
| #' | ||||||||
| count <- function(df, vars = NULL, wt_var = NULL) { | ||||||||
| df2 <- if (is.null(vars)) df else df[vars] | ||||||||
| id <- id(df2, drop = TRUE) | ||||||||
| u_id <- !duplicated(id) | ||||||||
| labels <- df2[u_id, , drop = FALSE] | ||||||||
| labels <- labels[order(id[u_id]), , drop = FALSE] | ||||||||
| if (is.null(wt_var)) { | ||||||||
| freq <- tabulate(id, attr(id, "n")) | ||||||||
| } else { | ||||||||
| wt <- .subset2(df, wt_var) | ||||||||
| freq <- vapply(split(wt, id), sum, numeric(1)) | ||||||||
| } | ||||||||
| new_data_frame(c(as.list(labels), list(n = freq))) | ||||||||
| } | ||||||||
| # Adapted from plyr::join.keys | ||||||||
| # Create a shared unique id across two data frames such that common variable | ||||||||
| # combinations in the two data frames gets the same id | ||||||||
| join_keys <- function(x, y, by) { | ||||||||
| joint <- rbind_dfs(list(x[by], y[by])) | ||||||||
| keys <- id(joint, drop = TRUE) | ||||||||
| n_x <- nrow(x) | ||||||||
| n_y <- nrow(y) | ||||||||
| list(x = keys[seq_len(n_x)], y = keys[n_x + seq_len(n_y)], | ||||||||
| n = attr(keys, "n")) | ||||||||
| } | ||||||||
| #' Replace specified values with new values, in a factor or character vector | ||||||||
| #' | ||||||||
| #' An easy to use substitution of elements in a string-like vector (character or | ||||||||
| #' factor). If `x` is a character vector the matching elements will be replaced | ||||||||
| #' directly and if `x` is a factor the matching levels will be replaced | ||||||||
| #' | ||||||||
| #' @param x A character or factor vector | ||||||||
| #' @param replace A named character vector with the names corresponding to the | ||||||||
| #' elements to replace and the values giving the replacement. | ||||||||
| #' | ||||||||
| #' @return A vector of the same class as `x` with the given values replaced | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @noRd | ||||||||
| #' | ||||||||
| revalue <- function(x, replace) { | ||||||||
| if (is.character(x)) { | ||||||||
| replace <- replace[names(replace) %in% x] | ||||||||
| if (length(replace) == 0) return(x) | ||||||||
| x[match(names(replace), x)] <- replace | ||||||||
| } else if (is.factor(x)) { | ||||||||
| lev <- levels(x) | ||||||||
| replace <- replace[names(replace) %in% lev] | ||||||||
| if (length(replace) == 0) return(x) | ||||||||
| lev[match(names(replace), lev)] <- replace | ||||||||
| levels(x) <- lev | ||||||||
| } else if (!is.null(x)) { | ||||||||
| abort("x is not a factor or character vector") | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| # Iterate through a formula and return a quoted version | ||||||||
| simplify_formula <- function(x) { | ||||||||
| if (length(x) == 2 && x[[1]] == as.name("~")) { | ||||||||
| return(simplify(x[[2]])) | ||||||||
| } | ||||||||
| if (length(x) < 3) | ||||||||
| return(list(x)) | ||||||||
| op <- x[[1]] | ||||||||
| a <- x[[2]] | ||||||||
| b <- x[[3]] | ||||||||
| if (op == as.name("+") || op == as.name("*") || op == | ||||||||
| as.name("~")) { | ||||||||
| c(simplify(a), simplify(b)) | ||||||||
| } | ||||||||
| else if (op == as.name("-")) { | ||||||||
| c(simplify(a), bquote(-.(x), list(x = simplify(b)))) | ||||||||
| } | ||||||||
| else { | ||||||||
| list(x) | ||||||||
| } | ||||||||
| } | ||||||||
| #' Create a quoted version of x | ||||||||
| #' | ||||||||
| #' This function captures the special meaning of formulas in the context of | ||||||||
| #' facets in ggplot2, where `+` have special meaning. It works as | ||||||||
| #' `plyr::as.quoted` but only for the special cases of `character`, `call`, and | ||||||||
| #' `formula` input as these are the only situations relevant for ggplot2. | ||||||||
| #' | ||||||||
| #' @param x A formula, string, or call to be quoted | ||||||||
| #' @param env The environment to a attach to the quoted expression. | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @noRd | ||||||||
| #' | ||||||||
| as.quoted <- function(x, env = parent.frame()) { | ||||||||
| x <- if (is.character(x)) { | ||||||||
| lapply(x, function(x) parse(text = x)[[1]]) | ||||||||
| } else if (is.formula(x)) { | ||||||||
| simplify_formula(x) | ||||||||
| } else if (is.call(x)) { | ||||||||
| as.list(x)[-1] | ||||||||
| } else { | ||||||||
| abort("Only knows how to quote characters, calls, and formula") | ||||||||
| } | ||||||||
| attributes(x) <- list(env = env, class = 'quoted') | ||||||||
| x | ||||||||
| } | ||||||||
| # round a number to a given precision | ||||||||
| round_any <- function(x, accuracy, f = round) { | ||||||||
| if (!is.numeric(x)) abort("`x` must be numeric") | ||||||||
| f(x/accuracy) * accuracy | ||||||||
| } | ||||||||
| #' Bind data frames together by common column names | ||||||||
| #' | ||||||||
| #' This function is akin to `plyr::rbind.fill`, `dplyr::bind_rows`, and | ||||||||
| #' `data.table::rbindlist`. It takes data frames in a list and stacks them on | ||||||||
| #' top of each other, filling out values with `NA` if the column is missing from | ||||||||
| #' a data.frame | ||||||||
| #' | ||||||||
| #' @param dfs A list of data frames | ||||||||
| #' | ||||||||
| #' @return A data.frame with the union of all columns from the data frames given | ||||||||
| #' in `dfs` | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @noRd | ||||||||
| #' | ||||||||
| rbind_dfs <- function(dfs) { | ||||||||
| out <- list() | ||||||||
| columns <- unique(unlist(lapply(dfs, names))) | ||||||||
| nrows <- vapply(dfs, .row_names_info, integer(1), type = 2L) | ||||||||
| total <- sum(nrows) | ||||||||
| if (length(columns) == 0) return(new_data_frame(list(), total)) | ||||||||
| allocated <- rep(FALSE, length(columns)) | ||||||||
| names(allocated) <- columns | ||||||||
| col_levels <- list() | ||||||||
| ord_levels <- list() | ||||||||
| for (df in dfs) { | ||||||||
| new_columns <- intersect(names(df), columns[!allocated]) | ||||||||
| for (col in new_columns) { | ||||||||
| if (is.factor(df[[col]])) { | ||||||||
| all_ordered <- all(vapply(dfs, function(df) { | ||||||||
| val <- .subset2(df, col) | ||||||||
| is.null(val) || is.ordered(val) | ||||||||
| }, logical(1))) | ||||||||
| all_factors <- all(vapply(dfs, function(df) { | ||||||||
| val <- .subset2(df, col) | ||||||||
| is.null(val) || is.factor(val) | ||||||||
| }, logical(1))) | ||||||||
| if (all_ordered) { | ||||||||
| ord_levels[[col]] <- unique(unlist(lapply(dfs, function(df) levels(.subset2(df, col))))) | ||||||||
| } else if (all_factors) { | ||||||||
| col_levels[[col]] <- unique(unlist(lapply(dfs, function(df) levels(.subset2(df, col))))) | ||||||||
| } | ||||||||
| out[[col]] <- rep(NA_character_, total) | ||||||||
| } else { | ||||||||
| out[[col]] <- rep(.subset2(df, col)[1][NA], total) | ||||||||
| } | ||||||||
| } | ||||||||
| allocated[new_columns] <- TRUE | ||||||||
| if (all(allocated)) break | ||||||||
| } | ||||||||
| is_date <- lapply(out, inherits, 'Date') | ||||||||
| is_time <- lapply(out, inherits, 'POSIXct') | ||||||||
| pos <- c(cumsum(nrows) - nrows + 1) | ||||||||
| for (i in seq_along(dfs)) { | ||||||||
| df <- dfs[[i]] | ||||||||
| rng <- seq(pos[i], length.out = nrows[i]) | ||||||||
| for (col in names(df)) { | ||||||||
| date_col <- inherits(df[[col]], 'Date') | ||||||||
| time_col <- inherits(df[[col]], 'POSIXct') | ||||||||
| if (is_date[[col]] && !date_col) { | ||||||||
| out[[col]][rng] <- as.Date( | ||||||||
| unclass(df[[col]]), | ||||||||
| origin = ggplot_global$date_origin | ||||||||
| ) | ||||||||
| } else if (is_time[[col]] && !time_col) { | ||||||||
| out[[col]][rng] <- as.POSIXct( | ||||||||
| unclass(df[[col]]), | ||||||||
| origin = ggplot_global$time_origin | ||||||||
| ) | ||||||||
| } else if (date_col || time_col || inherits(df[[col]], 'factor')) { | ||||||||
| out[[col]][rng] <- as.character(df[[col]]) | ||||||||
| } else { | ||||||||
| out[[col]][rng] <- df[[col]] | ||||||||
| } | ||||||||
| } | ||||||||
| } | ||||||||
| for (col in names(ord_levels)) { | ||||||||
| out[[col]] <- ordered(out[[col]], levels = ord_levels[[col]]) | ||||||||
| } | ||||||||
| for (col in names(col_levels)) { | ||||||||
| out[[col]] <- factor(out[[col]], levels = col_levels[[col]]) | ||||||||
| } | ||||||||
| attributes(out) <- list( | ||||||||
| class = "data.frame", | ||||||||
| names = names(out), | ||||||||
| row.names = .set_row_names(total) | ||||||||
| ) | ||||||||
| out | ||||||||
| } | ||||||||
| #' Apply function to unique subsets of a data.frame | ||||||||
| #' | ||||||||
| #' This function is akin to `plyr::ddply`. It takes a single data.frame, | ||||||||
| #' splits it by the unique combinations of the columns given in `by`, apply a | ||||||||
| #' function to each split, and then reassembles the results into a sigle | ||||||||
| #' data.frame again. | ||||||||
| #' | ||||||||
| #' @param df A data.frame | ||||||||
| #' @param by A character vector of column names to split by | ||||||||
| #' @param fun A function to apply to each split | ||||||||
| #' @param ... Further arguments to `fun` | ||||||||
| #' @param drop Should unused factor levels in the columns given in `by` be | ||||||||
| #' dropped. | ||||||||
| #' | ||||||||
| #' @return A data.frame if the result of `fun` does not include the columns | ||||||||
| #' given in `by` these will be prepended to the result. | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @noRd | ||||||||
| dapply <- function(df, by, fun, ..., drop = TRUE) { | ||||||||
| grouping_cols <- .subset(df, by) | ||||||||
| fallback_order <- unique(c(by, names(df))) | ||||||||
| apply_fun <- function(x) { | ||||||||
| res <- fun(x, ...) | ||||||||
| if (is.null(res)) return(res) | ||||||||
| if (length(res) == 0) return(new_data_frame()) | ||||||||
| vars <- lapply(setNames(by, by), function(col) .subset2(x, col)[1]) | ||||||||
| if (is.matrix(res)) res <- split_matrix(res) | ||||||||
| if (is.null(names(res))) names(res) <- paste0("V", seq_along(res)) | ||||||||
| if (all(by %in% names(res))) return(new_data_frame(unclass(res))) | ||||||||
| res <- modify_list(unclass(vars), unclass(res)) | ||||||||
| new_data_frame(res[intersect(c(fallback_order, names(res)), names(res))]) | ||||||||
| } | ||||||||
| # Shortcut when only one group | ||||||||
| if (all(vapply(grouping_cols, single_value, logical(1)))) { | ||||||||
| return(apply_fun(df)) | ||||||||
| } | ||||||||
| ids <- id(grouping_cols, drop = drop) | ||||||||
| group_rows <- split_with_index(seq_len(nrow(df)), ids) | ||||||||
| rbind_dfs(lapply(seq_along(group_rows), function(i) { | ||||||||
| cur_data <- df_rows(df, group_rows[[i]]) | ||||||||
| apply_fun(cur_data) | ||||||||
| })) | ||||||||
| } | ||||||||
| single_value <- function(x, ...) { | ||||||||
| UseMethod("single_value") | ||||||||
| } | ||||||||
| #' @export | ||||||||
| single_value.default <- function(x, ...) { | ||||||||
| # This is set by id() used in creating the grouping var | ||||||||
| identical(attr(x, "n"), 1L) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| single_value.factor <- function(x, ...) { | ||||||||
| # Panels are encoded as factor numbers and can never be missing (NA) | ||||||||
| identical(levels(x), "1") | ||||||||
| } | ||||||||
| ggplot2/R/aes.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' @include utilities.r compat-plyr.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 | ||||||||
| #' [ggplot()] 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 (e.g., `pch` to `shape` and `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](https://dplyr.tidyverse.org/articles/programming.html) | ||||||||
| #' to learn more about these techniques. | ||||||||
| #' | ||||||||
| #' @param x,y,... List of name-value pairs in the form `aesthetic = variable` | ||||||||
| #' describing which variables in the layer data should be mapped to which | ||||||||
| #' aesthetics used by the paired geom/stat. The expression `variable` is | ||||||||
| #' evaluated within the layer data, so there is no need to refer to | ||||||||
| #' the original dataset (i.e., use `ggplot(df, aes(variable))` | ||||||||
| #' instead of `ggplot(df, aes(df$variable))`). 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 <- enquos(x = x, y = y, ..., .ignore_empty = "all") | ||||||||
| aes <- new_aes(exprs, 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 (is_quosure(x)) { | ||||||||
| if (!quo_is_symbolic(x)) { | ||||||||
| x <- quo_get_expr(x) | ||||||||
| } | ||||||||
| return(x) | ||||||||
| } | ||||||||
| if (is_symbolic(x)) { | ||||||||
| x <- new_quosure(x, env = env) | ||||||||
| return(x) | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| new_aes <- function(x, env = globalenv()) { | ||||||||
| if (!is.list(x)) { | ||||||||
| abort("`x` must be a list") | ||||||||
| } | ||||||||
| 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, 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 | ||||||||
| revalue(x, ggplot_global$base_to_ggplot) | ||||||||
| } | ||||||||
| # 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 = ", ") | ||||||||
| warn(glue("Duplicated aesthetics after name standardisation: {duplicated_message}")) | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| substitute_aes <- function(x) { | ||||||||
| x <- lapply(x, function(aesthetic) { | ||||||||
| as_quosure(standardise_aes_symbols(quo_get_expr(aesthetic)), env = environment(aesthetic)) | ||||||||
| }) | ||||||||
| class(x) <- "uneval" | ||||||||
| x | ||||||||
| } | ||||||||
| # x is a quoted expression from inside aes() | ||||||||
| standardise_aes_symbols <- function(x) { | ||||||||
| if (is.symbol(x)) { | ||||||||
| name <- standardise_aes_names(as_string(x)) | ||||||||
| return(sym(name)) | ||||||||
| } | ||||||||
| if (!is.call(x)) { | ||||||||
| return(x) | ||||||||
| } | ||||||||
| # Don't walk through function heads | ||||||||
| x[-1] <- lapply(x[-1], standardise_aes_symbols) | ||||||||
| 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) { | ||||||||
| as_quosure(x) | ||||||||
| } else if (is.call(x) || is.name(x) || is.atomic(x)) { | ||||||||
| new_aesthetic(x, caller_env) | ||||||||
| } else { | ||||||||
| abort("Aesthetic must be a one-sided formula, call, name, or constant.") | ||||||||
| } | ||||||||
| } | ||||||||
| 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 <- 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) 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, ...) { | ||||||||
| warn("aes_auto() is deprecated") | ||||||||
| # detect names of data | ||||||||
| if (is.null(data)) { | ||||||||
| abort("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] | ||||||||
| } | ||||||||
| #' Check a mapping for discouraged usage | ||||||||
| #' | ||||||||
| #' Checks that `$` and `[[` are not used when the target *is* the data | ||||||||
| #' | ||||||||
| #' @param mapping A mapping created with [aes()] | ||||||||
| #' @param data The data to be mapped from | ||||||||
| #' | ||||||||
| #' @noRd | ||||||||
| warn_for_aes_extract_usage <- function(mapping, data) { | ||||||||
| lapply(mapping, function(quosure) { | ||||||||
| warn_for_aes_extract_usage_expr(get_expr(quosure), data, get_env(quosure)) | ||||||||
| }) | ||||||||
| } | ||||||||
| warn_for_aes_extract_usage_expr <- function(x, data, env = emptyenv()) { | ||||||||
| if (is_call(x, "[[") || is_call(x, "$")) { | ||||||||
| if (extract_target_is_likely_data(x, data, env)) { | ||||||||
| good_usage <- alternative_aes_extract_usage(x) | ||||||||
| warn(glue("Use of `{format(x)}` is discouraged. Use `{good_usage}` instead.")) | ||||||||
| } | ||||||||
| } else if (is.call(x)) { | ||||||||
| lapply(x, warn_for_aes_extract_usage_expr, data, env) | ||||||||
| } | ||||||||
| } | ||||||||
| alternative_aes_extract_usage <- function(x) { | ||||||||
| if (is_call(x, "[[")) { | ||||||||
| good_call <- call2("[[", quote(.data), x[[3]]) | ||||||||
| format(good_call) | ||||||||
| } else if (is_call(x, "$")) { | ||||||||
| as.character(x[[3]]) | ||||||||
| } else { | ||||||||
| abort(glue("Don't know how to get alternative usage for `{format(x)}`")) | ||||||||
| } | ||||||||
| } | ||||||||
| extract_target_is_likely_data <- function(x, data, env) { | ||||||||
| if (!is.name(x[[2]])) { | ||||||||
| return(FALSE) | ||||||||
| } | ||||||||
| tryCatch({ | ||||||||
| data_eval <- eval_tidy(x[[2]], data, env) | ||||||||
| identical(data_eval, data) | ||||||||
| }, error = function(err) FALSE) | ||||||||
| } | ||||||||
| scales/R/labels-retired.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Older interface to `label_bytes()` | ||||||||
| #' | ||||||||
| #' \Sexpr[results=rd, stage=render]{lifecycle::badge("retired")} | ||||||||
| #' These functions are kept for backward compatibility, but you should switch | ||||||||
| #' to [label_bytes()] for new code. | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' @param symbol byte symbol to use. If "auto" the symbol used will be | ||||||||
| #' determined separately for each value of `x`. Valid symbols are "B", "kB", | ||||||||
| #' "MB", "GB", "TB", "PB", "EB", "ZB", and "YB" for SI units, and the "iB" | ||||||||
| #' variants for binary units. | ||||||||
| #' @param units which unit base to use, "binary" (1024 base) or "si" (1000 base) | ||||||||
| #' @export | ||||||||
| number_bytes_format <- function(symbol = "auto", units = "binary", ...) { | ||||||||
| force_all(symbol, units, ...) | ||||||||
| function(x) { | ||||||||
| number_bytes(x, symbol, units, ...) | ||||||||
| } | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname number_bytes_format | ||||||||
| number_bytes <- function(x, symbol = "auto", units = c("binary", "si"), accuracy = 1, ...) { | ||||||||
| units <- match.arg(units, c("binary", "si")) | ||||||||
| powers <- si_powers[si_powers >= 3] / 3 # powers of 1000 | ||||||||
| prefix <- names(powers) | ||||||||
| symbols <- c("B", switch(units, | ||||||||
| si = paste0(prefix, "B"), | ||||||||
| binary = paste0(toupper(prefix), "iB") | ||||||||
| )) | ||||||||
| symbol <- validate_byte_symbol(symbol, symbols) | ||||||||
| base <- switch(units, binary = 1024, si = 1000) | ||||||||
| if (symbol == "auto") { | ||||||||
| power <- findInterval(abs(x), base^powers) | ||||||||
| symbol <- symbols[1L + power] | ||||||||
| } else { | ||||||||
| power <- match(symbol, symbols) - 1L | ||||||||
| } | ||||||||
| number(x / base^power, accuracy = accuracy, suffix = paste0(" ", symbol), ...) | ||||||||
| } | ||||||||
| validate_byte_symbol <- function(symbol, symbols, default = "auto") { | ||||||||
| if (length(symbol) != 1) { | ||||||||
| n <- length(symbol) | ||||||||
| stop("`symbol` must have length 1, not length ", n, ".", call. = FALSE) | ||||||||
| } | ||||||||
| valid_symbols <- c(default, symbols) | ||||||||
| if (!(symbol %in% valid_symbols)) { | ||||||||
| warning( | ||||||||
| "`symbol` must be one of: '", paste0(valid_symbols, collapse = "', '"), | ||||||||
| "'; not '", symbol, "'.\n", | ||||||||
| "Defaulting to '", default, "'.", | ||||||||
| call. = FALSE | ||||||||
| ) | ||||||||
| symbol <- default | ||||||||
| } | ||||||||
| symbol | ||||||||
| } | ||||||||
| #' Format labels after transformation | ||||||||
| #' | ||||||||
| #' \Sexpr[results=rd, stage=render]{lifecycle::badge("retired")} | ||||||||
| #' | ||||||||
| #' @param trans transformation to apply | ||||||||
| #' @param format additional formatter to apply after transformation | ||||||||
| #' @return a function with single parameter x, a numeric vector, that | ||||||||
| #' returns a character vector of list of expressions | ||||||||
| #' @export | ||||||||
| #' @keywords internal | ||||||||
| #' @examples | ||||||||
| #' tf <- trans_format("log10", scientific_format()) | ||||||||
| #' tf(10 ^ 1:6) | ||||||||
| trans_format <- function(trans, format = scientific_format()) { | ||||||||
| if (is.character(trans)) trans <- match.fun(trans) | ||||||||
| force(format) | ||||||||
| function(x) { | ||||||||
| x <- trans(x) | ||||||||
| format(x) | ||||||||
| } | ||||||||
| } | ||||||||
| #' Unit labels | ||||||||
| #' | ||||||||
| #' \Sexpr[results=rd, stage=render]{lifecycle::badge("retired")} | ||||||||
| #' This function is kept for backward compatiblity; you should either use | ||||||||
| #' [label_number()] or [label_number_si()] instead. | ||||||||
| #' | ||||||||
| #' @inheritParams number_format | ||||||||
| #' @keywords internal | ||||||||
| #' @param unit The units to append. | ||||||||
| #' @param sep The separator between the number and the unit label. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # Label with units | ||||||||
| #' demo_continuous(c(0, 1), labels = unit_format(unit = "m")) | ||||||||
| #' # Labels in kg, but original data in g | ||||||||
| #' km <- unit_format(unit = "km", scale = 1e-3, digits = 2) | ||||||||
| #' demo_continuous(c(0, 2500), labels = km) | ||||||||
| unit_format <- function(accuracy = NULL, scale = 1, prefix = "", | ||||||||
| unit = "m", sep = " ", suffix = paste0(sep, unit), | ||||||||
| big.mark = " ", decimal.mark = ".", | ||||||||
| trim = TRUE, ...) { | ||||||||
| number_format( | ||||||||
| accuracy = accuracy, | ||||||||
| scale = scale, | ||||||||
| prefix = prefix, | ||||||||
| suffix = suffix, | ||||||||
| big.mark = big.mark, | ||||||||
| decimal.mark = decimal.mark, | ||||||||
| trim = trim, | ||||||||
| ... | ||||||||
| ) | ||||||||
| } | ||||||||
| #' Label using `format()` | ||||||||
| #' | ||||||||
| #' \Sexpr[results=rd, stage=render]{lifecycle::badge("retired")} | ||||||||
| #' This function is kept for backward compatiblity; you should either use | ||||||||
| #' [label_number()] or [label_date()] instead. | ||||||||
| #' | ||||||||
| #' @param ... Arguments passed on to [format()]. | ||||||||
| #' @export | ||||||||
| #' @keywords internal | ||||||||
| format_format <- function(...) { | ||||||||
| force_all(...) | ||||||||
| function(x) { | ||||||||
| if (!is.null(names(x))) return(names(x)) | ||||||||
| ret <- format(x, ..., trim = TRUE, justify = "left") | ||||||||
| # format.character() renders NA as "NA" | ||||||||
| ret[is.na(x)] <- NA | ||||||||
| ret | ||||||||
| } | ||||||||
| } | ||||||||
| rlang/R/attr.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| structure2 <- function(.x, ...) { | ||||||||
| exec("structure", .Data = .x, ...) | ||||||||
| } | ||||||||
| set_class <- function(x, class) { | ||||||||
| attr(x, "class") <- class | ||||||||
| x | ||||||||
| } | ||||||||
| #' Is object named? | ||||||||
| #' | ||||||||
| #' `is_named()` checks that `x` has names attributes, and that none of | ||||||||
| #' the names are missing or empty (`NA` or `""`). `is_dictionaryish()` | ||||||||
| #' checks that an object is a dictionary: that it has actual names and | ||||||||
| #' in addition that there are no duplicated names. `have_name()` | ||||||||
| #' is a vectorised version of `is_named()`. | ||||||||
| #' | ||||||||
| #' @param x An object to test. | ||||||||
| #' @return `is_named()` and `is_dictionaryish()` are scalar predicates | ||||||||
| #' and return `TRUE` or `FALSE`. `have_name()` is vectorised and | ||||||||
| #' returns a logical vector as long as the input. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # A data frame usually has valid, unique names | ||||||||
| #' is_named(mtcars) | ||||||||
| #' have_name(mtcars) | ||||||||
| #' is_dictionaryish(mtcars) | ||||||||
| #' | ||||||||
| #' # But data frames can also have duplicated columns: | ||||||||
| #' dups <- cbind(mtcars, cyl = seq_len(nrow(mtcars))) | ||||||||
| #' is_dictionaryish(dups) | ||||||||
| #' | ||||||||
| #' # The names are still valid: | ||||||||
| #' is_named(dups) | ||||||||
| #' have_name(dups) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' # For empty objects the semantics are slightly different. | ||||||||
| #' # is_dictionaryish() returns TRUE for empty objects: | ||||||||
| #' is_dictionaryish(list()) | ||||||||
| #' | ||||||||
| #' # But is_named() will only return TRUE if there is a names | ||||||||
| #' # attribute (a zero-length character vector in this case): | ||||||||
| #' x <- set_names(list(), character(0)) | ||||||||
| #' is_named(x) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' # Empty and missing names are invalid: | ||||||||
| #' invalid <- dups | ||||||||
| #' names(invalid)[2] <- "" | ||||||||
| #' names(invalid)[5] <- NA | ||||||||
| #' | ||||||||
| #' # is_named() performs a global check while have_name() can show you | ||||||||
| #' # where the problem is: | ||||||||
| #' is_named(invalid) | ||||||||
| #' have_name(invalid) | ||||||||
| #' | ||||||||
| #' # have_name() will work even with vectors that don't have a names | ||||||||
| #' # attribute: | ||||||||
| #' have_name(letters) | ||||||||
| is_named <- function(x) { | ||||||||
| nms <- names(x) | ||||||||
| if (is_null(nms)) { | ||||||||
| return(FALSE) | ||||||||
| } | ||||||||
| if (any(nms_are_invalid(nms))) { | ||||||||
| return(FALSE) | ||||||||
| } | ||||||||
| TRUE | ||||||||
| } | ||||||||
| #' @rdname is_named | ||||||||
| #' @export | ||||||||
| is_dictionaryish <- function(x) { | ||||||||
| if (!length(x)) { | ||||||||
| return(!is.null(x)) | ||||||||
| } | ||||||||
| is_named(x) && !any(duplicated(names(x))) | ||||||||
| } | ||||||||
| #' @rdname is_named | ||||||||
| #' @export | ||||||||
| have_name <- function(x) { | ||||||||
| nms <- names(x) | ||||||||
| if (is.null(nms)) { | ||||||||
| rep(FALSE, length(x)) | ||||||||
| } else { | ||||||||
| !nms_are_invalid(nms) | ||||||||
| } | ||||||||
| } | ||||||||
| nms_are_invalid <- function(x) { | ||||||||
| x == "" | is.na(x) | ||||||||
| } | ||||||||
| #' Does an object have an element with this name? | ||||||||
| #' | ||||||||
| #' This function returns a logical value that indicates if a data | ||||||||
| #' frame or another named object contains an element with a specific | ||||||||
| #' name. Note that `has_name()` only works with vectors. For instance, | ||||||||
| #' environments need the specialised function [env_has()]. | ||||||||
| #' | ||||||||
| #' Unnamed objects are treated as if all names are empty strings. `NA` | ||||||||
| #' input gives `FALSE` as output. | ||||||||
| #' | ||||||||
| #' @param x A data frame or another named object | ||||||||
| #' @param name Element name(s) to check | ||||||||
| #' @return A logical vector of the same length as `name` | ||||||||
| #' @examples | ||||||||
| #' has_name(iris, "Species") | ||||||||
| #' has_name(mtcars, "gears") | ||||||||
| #' @export | ||||||||
| has_name <- function(x, name) { | ||||||||
| name %in% names2(x) | ||||||||
| } | ||||||||
| #' Set names of a vector | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' \Sexpr[results=rd, stage=render]{rlang:::lifecycle("stable")} | ||||||||
| #' | ||||||||
| #' This is equivalent to [stats::setNames()], with more features and | ||||||||
| #' stricter argument checking. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @section Life cycle: | ||||||||
| #' | ||||||||
| #' `set_names()` is stable and exported in purrr. | ||||||||
| #' | ||||||||
| #' @param x Vector to name. | ||||||||
| #' @param nm,... Vector of names, the same length as `x`. | ||||||||
| #' | ||||||||
| #' You can specify names in the following ways: | ||||||||
| #' | ||||||||
| #' * If you do nothing, `x` will be named with itself. | ||||||||
| #' | ||||||||
| #' * If `x` already has names, you can provide a function or formula | ||||||||
| #' to transform the existing names. In that case, `...` is passed | ||||||||
| #' to the function. | ||||||||
| #' | ||||||||
| #' * If `nm` is `NULL`, the names are removed (if present). | ||||||||
| #' | ||||||||
| #' * In all other cases, `nm` and `...` are coerced to character. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' set_names(1:4, c("a", "b", "c", "d")) | ||||||||
| #' set_names(1:4, letters[1:4]) | ||||||||
| #' set_names(1:4, "a", "b", "c", "d") | ||||||||
| #' | ||||||||
| #' # If the second argument is ommitted a vector is named with itself | ||||||||
| #' set_names(letters[1:5]) | ||||||||
| #' | ||||||||
| #' # Alternatively you can supply a function | ||||||||
| #' set_names(1:10, ~ letters[seq_along(.)]) | ||||||||
| #' set_names(head(mtcars), toupper) | ||||||||
| #' | ||||||||
| #' # If the input vector is unnamed, it is first named after itself | ||||||||
| #' # before the function is applied: | ||||||||
| #' set_names(letters, toupper) | ||||||||
| #' | ||||||||
| #' # `...` is passed to the function: | ||||||||
| #' set_names(head(mtcars), paste0, "_foo") | ||||||||
| set_names <- function(x, nm = x, ...) { | ||||||||
| mold <- x | ||||||||
| .Call(rlang_set_names, x, mold, nm, environment()) | ||||||||
| } | ||||||||
| #' Get names of a vector | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' \Sexpr[results=rd, stage=render]{rlang:::lifecycle("stable")} | ||||||||
| #' | ||||||||
| #' This names getter always returns a character vector, even when an | ||||||||
| #' object does not have a `names` attribute. In this case, it returns | ||||||||
| #' a vector of empty names `""`. It also standardises missing names to | ||||||||
| #' `""`. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @section Life cycle: | ||||||||
| #' | ||||||||
| #' `names2()` is stable. | ||||||||
| #' | ||||||||
| #' @param x A vector. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' names2(letters) | ||||||||
| #' | ||||||||
| #' # It also takes care of standardising missing names: | ||||||||
| #' x <- set_names(1:3, c("a", NA, "b")) | ||||||||
| #' names2(x) | ||||||||
| names2 <- function(x) { | ||||||||
| .Call(rlang_names2, x, environment()) | ||||||||
| } | ||||||||
| # Avoids `NA` names on subset-assign with unnamed vectors | ||||||||
| `names2<-` <- function(x, value) { | ||||||||
| if (is_null(names(x))) { | ||||||||
| names(x) <- names2(x) | ||||||||
| } | ||||||||
| names(x) <- value | ||||||||
| x | ||||||||
| } | ||||||||
| length_ <- function(x) { | ||||||||
| .Call(rlang_length, x) | ||||||||
| } | ||||||||
| #' How long is an object? | ||||||||
| #' | ||||||||
| #' This is a function for the common task of testing the length of an | ||||||||
| #' object. It checks the length of an object in a non-generic way: | ||||||||
| #' [base::length()] methods are ignored. | ||||||||
| #' | ||||||||
| #' @param x A R object. | ||||||||
| #' @param n A specific length to test `x` with. If `NULL`, | ||||||||
| #' `has_length()` returns `TRUE` if `x` has length greater than | ||||||||
| #' zero, and `FALSE` otherwise. | ||||||||
| #' @export | ||||||||
| #' @keywords internal | ||||||||
| #' @examples | ||||||||
| #' has_length(list()) | ||||||||
| #' has_length(list(), 0) | ||||||||
| #' | ||||||||
| #' has_length(letters) | ||||||||
| #' has_length(letters, 20) | ||||||||
| #' has_length(letters, 26) | ||||||||
| has_length <- function(x, n = NULL) { | ||||||||
| len <- .Call(rlang_length, x) | ||||||||
| if (is_null(n)) { | ||||||||
| as.logical(len) | ||||||||
| } else { | ||||||||
| len == n | ||||||||
| } | ||||||||
| } | ||||||||
| poke_attributes <- function(x, attrs) { | ||||||||
| .Call(rlang_poke_attrib, x, attrs) | ||||||||
| } | ||||||||
| #' Zap source references | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' There are a number of situations where R creates source references: | ||||||||
| #' | ||||||||
| #' - Reading R code from a file with `source()` and `parse()` might save | ||||||||
| #' source references inside calls to `function` and `{`. | ||||||||
| #' - [sys.call()] includes a source reference if possible. | ||||||||
| #' - Creating a closure stores the source reference from the call to | ||||||||
| #' `function`, if any. | ||||||||
| #' | ||||||||
| #' These source references take up space and might cause a number of | ||||||||
| #' issues. `zap_srcref()` recursively walks through expressions and | ||||||||
| #' functions to remove all source references. | ||||||||
| #' | ||||||||
| #' @param x An R object. Functions and calls are walked recursively. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| zap_srcref <- function(x) { | ||||||||
| if (is_closure(x)) { | ||||||||
| body(x) <- zap_srcref(body(x)) | ||||||||
| return(x) | ||||||||
| } | ||||||||
| if (!is_call(x)) { | ||||||||
| return(x) | ||||||||
| } | ||||||||
| x <- duplicate(x, shallow = TRUE) | ||||||||
| if (!is_null(sexp_attrib(x))) { | ||||||||
| attr(x, "srcref") <- NULL | ||||||||
| attr(x, "wholeSrcref") <- NULL | ||||||||
| attr(x, "srcfile") <- NULL | ||||||||
| } | ||||||||
| if (is_call(x, "function")) { | ||||||||
| node <- node_get(x, 3) | ||||||||
| if (!is_null(node)) { | ||||||||
| node_poke_cdr(node, NULL) | ||||||||
| } | ||||||||
| } | ||||||||
| node <- x | ||||||||
| while (!is_null(node)) { | ||||||||
| node_poke_car(node, zap_srcref(node_car(node))) | ||||||||
| node <- node_cdr(node) | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| tibble/R/names.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| set_repaired_names <- function(x, | ||||||||
| .name_repair = c("check_unique", "unique", "universal", "minimal"), | ||||||||
| quiet = FALSE) { | ||||||||
| set_names(x, repaired_names(names2(x), .name_repair = .name_repair, quiet = quiet)) | ||||||||
| } | ||||||||
| repaired_names <- function(name, | ||||||||
| .name_repair = c("check_unique", "unique", "universal", "minimal"), | ||||||||
| quiet = FALSE, | ||||||||
| details = NULL) { | ||||||||
| subclass_name_repair_errors(name = name, details = details, | ||||||||
| vec_as_names(name, repair = .name_repair, quiet = quiet || !is_character(.name_repair)) | ||||||||
| ) | ||||||||
| } | ||||||||
| # Errors ------------------------------------------------------------------ | ||||||||
| error_column_names_cannot_be_empty <- function(names, repair = has_tibble_arg(".name_repair"), parent = NULL) { | ||||||||
| tibble_error(invalid_df("must be named", names, use_repair(repair)), names = names, parent = parent) | ||||||||
| } | ||||||||
| error_column_names_cannot_be_dot_dot <- function(names, repair = has_tibble_arg(".name_repair"), parent = NULL) { | ||||||||
| tibble_error(invalid_df("must not have names of the form ... or ..j", names, use_repair(repair)), names = names, parent = parent) | ||||||||
| } | ||||||||
| error_column_names_must_be_unique <- function(names, repair = has_tibble_arg(".name_repair"), parent = NULL) { | ||||||||
| tibble_error(pluralise_commas("Column name(s) ", tick(names), " must not be duplicated.", use_repair(repair)), names = names, parent = parent) | ||||||||
| } | ||||||||
| # Subclassing errors ------------------------------------------------------ | ||||||||
| subclass_name_repair_errors <- function(expr, name, details = NULL) { | ||||||||
| withCallingHandlers( | ||||||||
| expr, | ||||||||
| # FIXME: use cnd$names with vctrs >= 0.3.0 | ||||||||
| vctrs_error_names_cannot_be_empty = function(cnd) { | ||||||||
| cnd <- error_column_names_cannot_be_empty(detect_empty_names(name), parent = cnd) | ||||||||
| cnd$body <- details | ||||||||
| cnd_signal(cnd) | ||||||||
| }, | ||||||||
| vctrs_error_names_cannot_be_dot_dot = function(cnd) { | ||||||||
| cnd <- error_column_names_cannot_be_dot_dot(detect_dot_dot(name), parent = cnd) | ||||||||
| cnd_signal(cnd) | ||||||||
| }, | ||||||||
| vctrs_error_names_must_be_unique = function(cnd) { | ||||||||
| cnd <- error_column_names_must_be_unique(detect_duplicates(name), parent = cnd) | ||||||||
| cnd_signal(cnd) | ||||||||
| } | ||||||||
| ) | ||||||||
| } | ||||||||
| # Anticipate vctrs 0.3.0 release: locations replaced by names | ||||||||
| detect_empty_names <- function(names) { | ||||||||
| which(names == "") | ||||||||
| } | ||||||||
| detect_dot_dot <- function(names) { | ||||||||
| grep("^[.][.](?:[.]|[1-9][0-9]*)$", names) | ||||||||
| } | ||||||||
| detect_duplicates <- function(names) { | ||||||||
| names[which(duplicated(names))] | ||||||||
| } | ||||||||
| tibble/R/as_tibble.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Coerce lists, matrices, and more to data frames | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' `r lifecycle::badge("maturing")` | ||||||||
| #' | ||||||||
| #' `as_tibble()` turns an existing object, such as a data frame or | ||||||||
| #' matrix, into a so-called tibble, a data frame with class [`tbl_df`]. This is | ||||||||
| #' in contrast with [tibble()], which builds a tibble from individual columns. | ||||||||
| #' `as_tibble()` is to [`tibble()`] as [base::as.data.frame()] is to | ||||||||
| #' [base::data.frame()]. | ||||||||
| #' | ||||||||
| #' `as_tibble()` is an S3 generic, with methods for: | ||||||||
| #' * [`data.frame`][base::data.frame()]: Thin wrapper around the `list` method | ||||||||
| #' that implements tibble's treatment of [rownames]. | ||||||||
| #' * [`matrix`][methods::matrix-class], [`poly`][stats::poly()], | ||||||||
| #' [`ts`][stats::ts()], [`table`][base::table()] | ||||||||
| #' * Default: Other inputs are first coerced with [base::as.data.frame()]. | ||||||||
| #' | ||||||||
| #' @section Row names: | ||||||||
| #' The default behavior is to silently remove row names. | ||||||||
| #' | ||||||||
| #' New code should explicitly convert row names to a new column using the | ||||||||
| #' `rownames` argument. | ||||||||
| #' | ||||||||
| #' For existing code that relies on the retention of row names, call | ||||||||
| #' `pkgconfig::set_config("tibble::rownames" = NA)` in your script or in your | ||||||||
| #' package's [.onLoad()] function. | ||||||||
| #' | ||||||||
| #' @section Life cycle: | ||||||||
| #' Using `as_tibble()` for vectors is superseded as of version 3.0.0, | ||||||||
| #' prefer the more expressive maturing `as_tibble_row()` and | ||||||||
| #' `as_tibble_col()` variants for new code. | ||||||||
| #' | ||||||||
| #' @seealso [tibble()] constructs a tibble from individual columns. [enframe()] | ||||||||
| #' converts a named vector to a tibble with a column of names and column of | ||||||||
| #' values. Name repair is implemented using [vctrs::vec_as_names()]. | ||||||||
| #' | ||||||||
| #' @param x A data frame, list, matrix, or other object that could reasonably be | ||||||||
| #' coerced to a tibble. | ||||||||
| #' @param ... Unused, for extensibility. | ||||||||
| #' @inheritParams tibble | ||||||||
| #' @param rownames How to treat existing row names of a data frame or matrix: | ||||||||
| #' * `NULL`: remove row names. This is the default. | ||||||||
| #' * `NA`: keep row names. | ||||||||
| #' * A string: the name of a new column. Existing rownames are transferred | ||||||||
| #' into this column and the `row.names` attribute is deleted. | ||||||||
| #' Read more in [rownames]. | ||||||||
| #' @param _n,validate | ||||||||
| #' `r lifecycle::badge("soft-deprecated")` | ||||||||
| #' | ||||||||
| #' For compatibility only, do not use for new code. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' m <- matrix(rnorm(50), ncol = 5) | ||||||||
| #' colnames(m) <- c("a", "b", "c", "d", "e") | ||||||||
| #' df <- as_tibble(m) | ||||||||
| as_tibble <- function(x, ..., | ||||||||
| .rows = NULL, | ||||||||
| .name_repair = c("check_unique", "unique", "universal", "minimal"), | ||||||||
| rownames = pkgconfig::get_config("tibble::rownames", NULL)) { | ||||||||
| UseMethod("as_tibble") | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname as_tibble | ||||||||
| as_tibble.data.frame <- function(x, validate = NULL, ..., | ||||||||
| .rows = NULL, | ||||||||
| .name_repair = c("check_unique", "unique", "universal", "minimal"), | ||||||||
| rownames = pkgconfig::get_config("tibble::rownames", NULL)) { | ||||||||
| .name_repair <- compat_name_repair(.name_repair, validate, missing(.name_repair)) | ||||||||
| old_rownames <- raw_rownames(x) | ||||||||
| if (is.null(.rows)) { | ||||||||
| .rows <- nrow(x) | ||||||||
| } | ||||||||
| result <- lst_to_tibble(unclass(x), .rows, .name_repair) | ||||||||
| if (is.null(rownames)) { | ||||||||
| result | ||||||||
| } else if (is.na(rownames)) { | ||||||||
| attr(result, "row.names") <- old_rownames | ||||||||
| result | ||||||||
| } else { | ||||||||
| if (length(old_rownames) > 0 && is.na(old_rownames[1L])) { # if implicit rownames | ||||||||
| old_rownames <- seq_len(abs(old_rownames[2L])) | ||||||||
| } | ||||||||
| old_rownames <- as.character(old_rownames) | ||||||||
| add_column(result, !!rownames := old_rownames, .before = 1L, .name_repair = "minimal") | ||||||||
| } | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname as_tibble | ||||||||
| as_tibble.list <- function(x, validate = NULL, ..., .rows = NULL, | ||||||||
| .name_repair = c("check_unique", "unique", "universal", "minimal")) { | ||||||||
| .name_repair <- compat_name_repair(.name_repair, validate, missing(.name_repair)) | ||||||||
| lst_to_tibble(x, .rows, .name_repair, col_lengths(x)) | ||||||||
| } | ||||||||
| lst_to_tibble <- function(x, .rows, .name_repair, lengths = NULL) { | ||||||||
| x <- unclass(x) | ||||||||
| x <- set_repaired_names(x, .name_repair) | ||||||||
| x <- check_valid_cols(x) | ||||||||
| recycle_columns(x, .rows, lengths) | ||||||||
| } | ||||||||
| compat_name_repair <- function(.name_repair, validate, .missing_name_repair) { | ||||||||
| if (is.null(validate)) return(.name_repair) | ||||||||
| if (!.missing_name_repair) { | ||||||||
| name_repair <- .name_repair | ||||||||
| } else if (isTRUE(validate)) { | ||||||||
| name_repair <- "check_unique" | ||||||||
| } else { | ||||||||
| name_repair <- "minimal" | ||||||||
| } | ||||||||
| deprecate_soft("2.0.0", "tibble::as_tibble(validate = )", "as_tibble(.name_repair =)", | ||||||||
| env = foreign_caller_env()) | ||||||||
| name_repair | ||||||||
| } | ||||||||
| check_valid_cols <- function(x, pos = NULL) { | ||||||||
| names_x <- names2(x) | ||||||||
| is_xd <- which(!map_lgl(x, is_valid_col)) | ||||||||
| if (has_length(is_xd)) { | ||||||||
| classes <- map_chr(x[is_xd], friendly_type_of) | ||||||||
| cnd_signal(error_column_scalar_type(names_x[is_xd], pos[is_xd], classes)) | ||||||||
| } | ||||||||
| # 657 | ||||||||
| x[] <- map(x, make_valid_col) | ||||||||
| invisible(x) | ||||||||
| } | ||||||||
| make_valid_col <- function(x) { | ||||||||
| if (is.expression(x)) { | ||||||||
| x <- as.list(x) | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| is_valid_col <- function(x) { | ||||||||
| # 657 | ||||||||
| vec_is(x) || is.expression(x) | ||||||||
| } | ||||||||
| recycle_columns <- function(x, .rows, lengths) { | ||||||||
| nrow <- guess_nrow(lengths, .rows) | ||||||||
| # Shortcut if all columns have the requested or implied length | ||||||||
| different_len <- which(lengths != nrow) | ||||||||
| if (is_empty(different_len)) return(new_tibble(x, nrow = nrow, subclass = NULL)) | ||||||||
| if (any(lengths[different_len] != 1)) { | ||||||||
| cnd_signal(error_incompatible_size(.rows, names(x), lengths, "Requested with `.rows` argument")) | ||||||||
| } | ||||||||
| if (nrow != 1L) { | ||||||||
| short <- which(lengths == 1L) | ||||||||
| if (has_length(short)) { | ||||||||
| x[short] <- map(x[short], vec_recycle, nrow) | ||||||||
| } | ||||||||
| } | ||||||||
| new_tibble(x, nrow = nrow, subclass = NULL) | ||||||||
| } | ||||||||
| guess_nrow <- function(lengths, .rows) { | ||||||||
| if (!is.null(.rows)) { | ||||||||
| return(.rows) | ||||||||
| } | ||||||||
| if (is_empty(lengths)) { | ||||||||
| return(0) | ||||||||
| } | ||||||||
| nontrivial_lengths <- lengths[lengths != 1L] | ||||||||
| if (is_empty(nontrivial_lengths)) { | ||||||||
| return(1) | ||||||||
| } | ||||||||
| max(nontrivial_lengths) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname as_tibble | ||||||||
| as_tibble.matrix <- function(x, ..., validate = NULL, .name_repair = NULL) { | ||||||||
| m <- matrixToDataFrame(x) | ||||||||
| names <- colnames(x) | ||||||||
| if (is.null(.name_repair)) { | ||||||||
| if ((is.null(names) || any(bad_names <- duplicated(names) | names == "")) && has_length(x)) { | ||||||||
| deprecate_warn("2.0.0", "as_tibble.matrix(x = 'must have unique column names if `.name_repair` is omitted')", | ||||||||
| details = "Using compatibility `.name_repair`.") | ||||||||
| compat_names <- paste0("V", seq_along(m)) | ||||||||
| if (is.null(names)) { | ||||||||
| names <- compat_names | ||||||||
| } else { | ||||||||
| names[bad_names] <- compat_names[bad_names] | ||||||||
| } | ||||||||
| .name_repair <- function(x) names | ||||||||
| } else { | ||||||||
| .name_repair <- "check_unique" | ||||||||
| } | ||||||||
| validate <- NULL | ||||||||
| } | ||||||||
| colnames(m) <- names | ||||||||
| as_tibble(m, ..., validate = validate, .name_repair = .name_repair) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| as_tibble.poly <- function(x, ...) { | ||||||||
| m <- matrixToDataFrame(unclass(x)) | ||||||||
| colnames(m) <- colnames(x) | ||||||||
| as_tibble(m, ...) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| as_tibble.ts <- function(x, ..., .name_repair = "minimal") { | ||||||||
| df <- as.data.frame(x) | ||||||||
| if (length(dim(x)) == 2) { | ||||||||
| colnames(df) <- colnames(x) | ||||||||
| } | ||||||||
| as_tibble(df, ..., .name_repair = .name_repair) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @param n Name for count column, default: `"n"`. | ||||||||
| #' @rdname as_tibble | ||||||||
| as_tibble.table <- function(x, `_n` = "n", ..., n = `_n`, .name_repair = "check_unique") { | ||||||||
| if (!missing(`_n`)) { | ||||||||
| warn("Please pass `n` as a named argument to `as_tibble.table()`.") | ||||||||
| } | ||||||||
| df <- as.data.frame(x, stringsAsFactors = FALSE) | ||||||||
| names(df) <- repaired_names( | ||||||||
| c(names2(dimnames(x)), n), .name_repair = .name_repair, | ||||||||
| details = "Use `names(dimnames(x)) <- ...` to assign names to a table." | ||||||||
| ) | ||||||||
| # Names already repaired: | ||||||||
| as_tibble(df, ..., .name_repair = "minimal") | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname as_tibble | ||||||||
| as_tibble.NULL <- function(x, ...) { | ||||||||
| if (missing(x)) { | ||||||||
| deprecate_soft("3.0.0", "as_tibble(x = 'can\\'t be missing')") | ||||||||
| } | ||||||||
| new_tibble(list(), nrow = 0) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname as_tibble | ||||||||
| as_tibble.default <- function(x, ...) { | ||||||||
| value <- x | ||||||||
| if (is_atomic(value)) { | ||||||||
| signal_superseded("3.0.0", "as_tibble(x = 'can\\'t be an atomic vector')", | ||||||||
| "as_tibble_col()") | ||||||||
| } | ||||||||
| as_tibble(as.data.frame(value, stringsAsFactors = FALSE), ...) | ||||||||
| } | ||||||||
| #' @description | ||||||||
| #' `as_tibble_row()` converts a vector to a tibble with one row. | ||||||||
| #' The input must be a bare vector, e.g. vectors of dates are not | ||||||||
| #' supported yet. | ||||||||
| #' If the input is a list, all elements must have length one. | ||||||||
| #' | ||||||||
| #' @rdname as_tibble | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' | ||||||||
| #' as_tibble_row(c(a = 1, b = 2)) | ||||||||
| #' as_tibble_row(list(c = "three", d = list(4:5))) | ||||||||
| #' as_tibble_row(1:3, .name_repair = "unique") | ||||||||
| as_tibble_row <- function(x, | ||||||||
| .name_repair = c("check_unique", "unique", "universal", "minimal")) { | ||||||||
| if (!is_bare_vector(x)) { | ||||||||
| # FIXME: Remove entry from help once fixed (#797) | ||||||||
| cnd_signal(error_as_tibble_row_bare(x)) | ||||||||
| } | ||||||||
| x <- set_repaired_names(x, .name_repair) | ||||||||
| check_all_lengths_one(x) | ||||||||
| new_tibble(as.list(x), nrow = 1) | ||||||||
| } | ||||||||
| check_all_lengths_one <- function(x) { | ||||||||
| sizes <- col_lengths(x) | ||||||||
| bad_lengths <- which(sizes != 1) | ||||||||
| if (!is_empty(bad_lengths)) { | ||||||||
| cnd_signal(error_as_tibble_row_size_one( | ||||||||
| seq_along(x)[bad_lengths], | ||||||||
| names2(x)[bad_lengths], | ||||||||
| sizes[bad_lengths]) | ||||||||
| ) | ||||||||
| } | ||||||||
| } | ||||||||
| #' @description | ||||||||
| #' `as_tibble_col()` converts a vector to a tibble with one column. | ||||||||
| #' | ||||||||
| #' @param column_name Name of the column. | ||||||||
| #' | ||||||||
| #' @rdname as_tibble | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' | ||||||||
| #' as_tibble_col(1:3) | ||||||||
| #' as_tibble_col( | ||||||||
| #' list(c = "three", d = list(4:5)), | ||||||||
| #' column_name = "data" | ||||||||
| #' ) | ||||||||
| as_tibble_col <- function(x, column_name = "value") { | ||||||||
| # Side effect: checking that x is a vector | ||||||||
| tibble(!!column_name := x) | ||||||||
| } | ||||||||
| # External ---------------------------------------------------------------- | ||||||||
| matrixToDataFrame <- function(x) { | ||||||||
| .Call(`tibble_matrixToDataFrame`, x) | ||||||||
| } | ||||||||
| # Errors ------------------------------------------------------------------ | ||||||||
| error_column_scalar_type <- function(names, positions, classes) { | ||||||||
| tibble_error( | ||||||||
| problems( | ||||||||
| "All columns in a tibble must be vectors:", | ||||||||
| x = paste0("Column ", name_or_pos(names, positions), " is ", classes) | ||||||||
| ), | ||||||||
| names = names | ||||||||
| ) | ||||||||
| } | ||||||||
| error_as_tibble_row_bare <- function(x) { | ||||||||
| tibble_error(paste0( | ||||||||
| "`x` must be a bare vector in `as_tibble_row()`, not ", class(x)[[1]], "." | ||||||||
| )) | ||||||||
| } | ||||||||
| error_as_tibble_row_size_one <- function(j, name, size) { | ||||||||
| desc <- tick(name) | ||||||||
| desc[name == ""] <- paste0("at position ", j[name == ""]) | ||||||||
| tibble_error(problems( | ||||||||
| "All elements must be size one, use `list()` to wrap.", | ||||||||
| paste0("Element ", desc, " is of size ", size, ".") | ||||||||
| )) | ||||||||
| } | ||||||||
| ggplot2/R/guides-none.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Empty guide | ||||||||
| #' | ||||||||
| #' This guide draws nothing. | ||||||||
| #' | ||||||||
| #' @inheritParams guide_axis | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' | ||||||||
| guide_none <- function(title = waiver(), position = waiver()) { | ||||||||
| structure( | ||||||||
| list( | ||||||||
| title = title, | ||||||||
| position = position, | ||||||||
| available_aes = "any" | ||||||||
| ), | ||||||||
| class = c("guide", "guide_none") | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| guide_train.guide_none <- function(guide, scale, aesthetic = NULL) { | ||||||||
| guide | ||||||||
| } | ||||||||
| #' @export | ||||||||
| guide_merge.guide_none <- function(guide, new_guide) { | ||||||||
| new_guide | ||||||||
| } | ||||||||
| #' @export | ||||||||
| guide_geom.guide_none <- function(guide, layers, default_mapping) { | ||||||||
| guide | ||||||||
| } | ||||||||
| #' @export | ||||||||
| guide_transform.guide_none <- function(guide, coord, panel_params) { | ||||||||
| guide | ||||||||
| } | ||||||||
| #' @export | ||||||||
| guide_gengrob.guide_none <- function(guide, theme, ...) { | ||||||||
| zeroGrob() | ||||||||
| } | ||||||||
| ggplot2/R/performance.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| # Fast data.frame constructor and indexing | ||||||||
| # No checking, recycling etc. unless asked for | ||||||||
| new_data_frame <- function(x = list(), n = NULL) { | ||||||||
| if (length(x) != 0 && is.null(names(x))) { | ||||||||
| abort("Elements must be named") | ||||||||
| } | ||||||||
| lengths <- vapply(x, length, integer(1)) | ||||||||
| if (is.null(n)) { | ||||||||
| n <- if (length(x) == 0 || min(lengths) == 0) 0 else max(lengths) | ||||||||
| } | ||||||||
| for (i in seq_along(x)) { | ||||||||
| if (lengths[i] == n) next | ||||||||
| if (lengths[i] != 1) { | ||||||||
| abort("Elements must equal the number of rows or 1") | ||||||||
| } | ||||||||
| x[[i]] <- rep(x[[i]], n) | ||||||||
| } | ||||||||
| class(x) <- "data.frame" | ||||||||
| attr(x, "row.names") <- .set_row_names(n) | ||||||||
| x | ||||||||
| } | ||||||||
| data_frame <- function(...) { | ||||||||
| new_data_frame(list(...)) | ||||||||
| } | ||||||||
| data.frame <- function(...) { | ||||||||
| abort(glue(" | ||||||||
| Please use `data_frame()` or `new_data_frame()` instead of `data.frame()` for better performance. | ||||||||
| See the vignette 'ggplot2 internal programming guidelines' for details. | ||||||||
| ")) | ||||||||
| } | ||||||||
| split_matrix <- function(x, col_names = colnames(x)) { | ||||||||
| force(col_names) | ||||||||
| x <- lapply(seq_len(ncol(x)), function(i) x[, i]) | ||||||||
| if (!is.null(col_names)) names(x) <- col_names | ||||||||
| x | ||||||||
| } | ||||||||
| mat_2_df <- function(x, col_names = colnames(x)) { | ||||||||
| new_data_frame(split_matrix(x, col_names)) | ||||||||
| } | ||||||||
| df_col <- function(x, name) .subset2(x, name) | ||||||||
| df_rows <- function(x, i) { | ||||||||
| new_data_frame(lapply(x, `[`, i = i)) | ||||||||
| } | ||||||||
| # More performant modifyList without recursion | ||||||||
| modify_list <- function(old, new) { | ||||||||
| for (i in names(new)) old[[i]] <- new[[i]] | ||||||||
| old | ||||||||
| } | ||||||||
| modifyList <- function(...) { | ||||||||
| abort(glue(" | ||||||||
| Please use `modify_list()` instead of `modifyList()` for better performance. | ||||||||
| See the vignette 'ggplot2 internal programming guidelines' for details. | ||||||||
| ")) | ||||||||
| } | ||||||||
| 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(labels, panel_params) labels, | ||||||||
| render_fg = function(panel_params, theme) element_render(theme, "panel.border"), | ||||||||
| render_bg = function(panel_params, theme) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| render_axis_h = function(panel_params, theme) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| render_axis_v = function(panel_params, theme) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| # transform range given in transformed coordinates | ||||||||
| # back into range in given in (possibly scale-transformed) | ||||||||
| # data coordinates | ||||||||
| backtransform_range = function(self, panel_params) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| # return range stored in panel_params | ||||||||
| range = function(panel_params) { | ||||||||
| abort("Not implemented") | ||||||||
| }, | ||||||||
| setup_panel_params = function(scale_x, scale_y, params = list()) { | ||||||||
| list() | ||||||||
| }, | ||||||||
| setup_panel_guides = function(self, panel_params, guides, params = list()) { | ||||||||
| panel_params | ||||||||
| }, | ||||||||
| train_panel_guides = function(self, panel_params, layers, default_mapping, params = list()) { | ||||||||
| panel_params | ||||||||
| }, | ||||||||
| 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") | ||||||||
| # 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") { | ||||||||
| draw_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")]])) { | ||||||||
| draw_axis(panel_params[[paste0(scale, ".sec.major")]], panel_params[[paste0(scale, ".sec.labels")]], position, theme) | ||||||||
| } else { | ||||||||
| zeroGrob() | ||||||||
| } | ||||||||
| } | ||||||||
| 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) | ||||||||
| } | ||||||||
| farver/R/aaa.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| colourspaces <- c( | ||||||||
| "cmy", # 0 | ||||||||
| "cmyk", # 1 | ||||||||
| "hsl", # 2 | ||||||||
| "hsb", # 3 | ||||||||
| "hsv", # 4 | ||||||||
| "lab", # 5 | ||||||||
| "hunterlab", # 6 | ||||||||
| "lch", # 7 | ||||||||
| "luv", # 8 | ||||||||
| "rgb", # 9 | ||||||||
| "xyz", # 10 | ||||||||
| "yxy", # 11 | ||||||||
| "hcl" # 11 | ||||||||
| ) | ||||||||
| colour_dims <- list( | ||||||||
| cmy = c('c', 'm', 'y'), | ||||||||
| cmyk = c('c', 'm', 'y', 'k'), | ||||||||
| hsl = c('h', 's', 'l'), | ||||||||
| hsb = c('h', 's', 'b'), | ||||||||
| hsv = c('h', 's', 'v'), | ||||||||
| lab = c('l', 'a', 'b'), | ||||||||
| hunterlab = c('l', 'a', 'b'), | ||||||||
| lch = c('l', 'c', 'h'), | ||||||||
| luv = c('l', 'u', 'v'), | ||||||||
| rgb = c('r', 'g', 'b'), | ||||||||
| xyz = c('x', 'y', 'z'), | ||||||||
| yxy = c('y1', 'x', 'y2'), | ||||||||
| hcl = c('h', 'c', 'l') | ||||||||
| ) | ||||||||
| colour_channel_index <- list( | ||||||||
| cmy = c('c' = 1L, 'm' = 2L, 'y' = 3L), | ||||||||
| cmyk = c('c' = 1L, 'm' = 2L, 'y' = 3L, 'k' = 4L), | ||||||||
| hsl = c('h' = 1L, 's' = 2L, 'l' = 3L), | ||||||||
| hsb = c('h' = 1L, 's' = 2L, 'b' = 3L), | ||||||||
| hsv = c('h' = 1L, 's' = 2L, 'v' = 3L), | ||||||||
| lab = c('l' = 1L, 'a' = 2L, 'b' = 3L), | ||||||||
| hunterlab = c('l' = 1L, 'a' = 2L, 'b' = 3L), | ||||||||
| lch = c('l' = 1L, 'c' = 2L, 'h' = 3L), | ||||||||
| luv = c('l' = 1L, 'u' = 2L, 'v' = 3L), | ||||||||
| rgb = c('r' = 1L, 'g' = 2L, 'b' = 3L), | ||||||||
| xyz = c('x' = 1L, 'y' = 2L, 'z' = 3L), | ||||||||
| yxy = c('y1' = 1L, 'x' = 2L, 'y2' = 3L), | ||||||||
| hcl = c('h' = 1L, 'c' = 2L, 'l' = 3L) | ||||||||
| ) | ||||||||
| distances <- c( | ||||||||
| "euclidean", | ||||||||
| "cie1976", | ||||||||
| "cie94", | ||||||||
| "cie2000", | ||||||||
| "cmc" | ||||||||
| ) | ||||||||
| operations <- c( | ||||||||
| "set", | ||||||||
| "add", | ||||||||
| "multiply", | ||||||||
| "least", | ||||||||
| "most" | ||||||||
| ) | ||||||||
| colourspace_match <- function(colour) { | ||||||||
| m <- pmatch(tolower(colour), colourspaces) | ||||||||
| if (is.na(m)) stop("Unknown colour space", call. = FALSE) | ||||||||
| m | ||||||||
| } | ||||||||
| distance_match <- function(dist) { | ||||||||
| m <- pmatch(match.arg(tolower(dist), distances), distances) | ||||||||
| if (is.na(m)) stop("Unknown distance measure", call. = FALSE) | ||||||||
| m | ||||||||
| } | ||||||||
| operation_match <- function(op) { | ||||||||
| m <- pmatch(match.arg(tolower(op), operations), operations) | ||||||||
| if (is.na(m)) stop("Unknown operation", call. = FALSE) | ||||||||
| m | ||||||||
| } | ||||||||
| white_references <- list( | ||||||||
| "2" = list( | ||||||||
| A = c(0.44757, 0.40745), | ||||||||
| B = c(0.34842, 0.35161), | ||||||||
| C = c(0.31006, 0.31616), | ||||||||
| D50 = c(0.34567, 0.35850), | ||||||||
| D55 = c(0.33242, 0.34743), | ||||||||
| D65 = c(0.31271, 0.32902), | ||||||||
| D75 = c(0.29902, 0.31485), | ||||||||
| E = c(1/3, 1/3), | ||||||||
| F1 = c(0.31310, 0.33727), | ||||||||
| F2 = c(0.37208, 0.37529), | ||||||||
| F3 = c(0.40910, 0.39430), | ||||||||
| F4 = c(0.44018, 0.40329), | ||||||||
| F5 = c(0.31379, 0.34531), | ||||||||
| F6 = c(0.37790, 0.38835), | ||||||||
| F7 = c(0.31292, 0.32933), | ||||||||
| F8 = c(0.34588, 0.35875), | ||||||||
| F9 = c(0.37417, 0.37281), | ||||||||
| F10 = c(0.34609, 0.35986), | ||||||||
| F11 = c(0.38052, 0.37713), | ||||||||
| F12 = c(0.43695, 0.40441) | ||||||||
| ), | ||||||||
| "10" = list( | ||||||||
| A = c(0.45117, 0.40594), | ||||||||
| B = c(0.34980, 0.35270), | ||||||||
| C = c(0.31039, 0.31905), | ||||||||
| D50 = c(0.34773, 0.35952), | ||||||||
| D55 = c(0.33411, 0.34877), | ||||||||
| D65 = c(0.31382, 0.33100), | ||||||||
| D75 = c(0.29968, 0.31740), | ||||||||
| E = c(1/3, 1/3), | ||||||||
| F1 = c(0.31811, 0.33559), | ||||||||
| F2 = c(0.37925, 0.36733), | ||||||||
| F3 = c(0.41761, 0.38324), | ||||||||
| F4 = c(0.44920, 0.39074), | ||||||||
| F5 = c(0.31975, 0.34246), | ||||||||
| F6 = c(0.38660, 0.37847), | ||||||||
| F7 = c(0.31569, 0.32960), | ||||||||
| F8 = c(0.34902, 0.35939), | ||||||||
| F9 = c(0.37829, 0.37045), | ||||||||
| F10 = c(0.35090, 0.35444), | ||||||||
| F11 = c(0.38541, 0.37123), | ||||||||
| F12 = c(0.44256, 0.39717) | ||||||||
| ) | ||||||||
| ) | ||||||||
| #' Convert value to a tristimulus values normalised to Y=100 | ||||||||
| #' | ||||||||
| #' This function can take either the name of a standardised illuminants, x | ||||||||
| #' and y chromaticity coordinates or X, Y, and Z tristimulus values and converts | ||||||||
| #' it to tristimulus values normalised to Y=100. All Illuminant series A-F are | ||||||||
| #' supported and can be queried both on the CIE 1931 2° and CIE 1964 10° | ||||||||
| #' chromaticity coordinates. | ||||||||
| #' | ||||||||
| #' @param x A string giving the name of the standardized illuminant or a | ||||||||
| #' 2 (chromaticity) or 3 (trsitimulus) length numeric vector. | ||||||||
| #' | ||||||||
| #' @param fow The field-of-view for the illuminant - either `2` or `10` | ||||||||
| #' | ||||||||
| #' @return A 3-length vector with tristimulus values | ||||||||
| #' | ||||||||
| #' @keywords internal | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Using names | ||||||||
| #' as_white_ref('D65') | ||||||||
| #' | ||||||||
| #' # Using chromaticity values | ||||||||
| #' as_white_ref(c(0.3, 0.4)) | ||||||||
| as_white_ref <- function(x, fow = 2) { | ||||||||
| if (is.character(x)) { | ||||||||
| x <- white_references[[as.character(fow)]][[toupper(x)]] | ||||||||
| if (is.null(x)) stop('Unknown white reference', call. = FALSE) | ||||||||
| } | ||||||||
| if (is.integer(x)) x <- as.numeric(x) | ||||||||
| if (!is.numeric(x)) stop('White reference must be a numeric vector', call. = FALSE) | ||||||||
| if (length(x) == 2) { | ||||||||
| tmp <- 100/x[2] | ||||||||
| x <- c( | ||||||||
| tmp * x[1], | ||||||||
| 100, | ||||||||
| tmp * (1 - sum(x)) | ||||||||
| ) | ||||||||
| } else if (length(x) == 3) { | ||||||||
| if (x[2] != 100) { | ||||||||
| x <- x * 100 / x[2] | ||||||||
| } | ||||||||
| } else { | ||||||||
| stop('White reference must be of length 2 (chromaticity) or 3 (tristimulus)', call. = FALSE) | ||||||||
| } | ||||||||
| structure(x, names = c('X', 'Y', 'Z')) | ||||||||
| } | ||||||||
| load_colour_names <- function() { | ||||||||
| .Call('load_colour_names_c', | ||||||||
| c(all_colours, as.character(seq_along(def_palette) - 1L)), | ||||||||
| cbind(all_values, def_palette_values), | ||||||||
| PACKAGE = 'farver') | ||||||||
| invisible() | ||||||||
| } | ||||||||
| as_colour_code <- function(x) { | ||||||||
| if (is.character(x)) return(x) | ||||||||
| n <- names(x) | ||||||||
| if (is.numeric(x)) { | ||||||||
| if (any(x <= 0, na.rm = TRUE)) { | ||||||||
| stop("colours encodes as numbers must be positive", call. = FALSE) | ||||||||
| } | ||||||||
| x <- as.integer(x) | ||||||||
| x <- ifelse(x == 0, 1, ((x - 1) %% (length(def_palette) - 1)) + 2) | ||||||||
| x <- def_palette[x] | ||||||||
| } else { | ||||||||
| x <- as.character(x) | ||||||||
| } | ||||||||
| names(x) <- n | ||||||||
| x | ||||||||
| } | ||||||||
| farver/R/decode.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Decode RGB hex-strings into colour values | ||||||||
| #' | ||||||||
| #' This is a version of [grDevices::col2rgb()] that returns the colour values in | ||||||||
| #' the standard form expected by farver (matrix with a row per colour). As with | ||||||||
| #' [encode_colour()] it can do colour conversion on the fly, meaning that you can | ||||||||
| #' decode a hex string directly into any of the supported colour spaces. | ||||||||
| #' | ||||||||
| #' @inheritSection convert_colour Handling of non-finite and out of bounds values | ||||||||
| #' | ||||||||
| #' @param colour A character vector of hex-encoded values or a valid colour name | ||||||||
| #' as given in [grDevices::colours()]. | ||||||||
| #' @param alpha If `TRUE` the alpha channel will be returned as well (scaled | ||||||||
| #' between 0 and 1). If no alpha channel exists in the colour it will be | ||||||||
| #' assumed 1. If `FALSE` any alpha channel is ignored. | ||||||||
| #' @param to The output colour space. Allowed values are: `"cmy"`, | ||||||||
| #' `"cmyk"`, `"hsl"`, `"hsb"`, `"hsv"`, `"lab"` (CIE L*ab), `"hunterlab"` | ||||||||
| #' (Hunter Lab), `"lch"` (CIE Lch(ab) / polarLAB), `"luv"`, `"rgb"` (sRGB), | ||||||||
| #' `"xyz"`, `"yxy"` (CIE xyY), or `"hcl"` (CIE Lch(uv) / polarLuv) | ||||||||
| #' @param white The white reference of the output colour space. Will only have | ||||||||
| #' an effect for relative colour spaces such as Lab and luv. Any value accepted | ||||||||
| #' by [as_white_ref()] allowed. | ||||||||
| #' @param na_value A valid colour string or `NA` to use when `colour` contains | ||||||||
| #' `NA` elements. The general approach in farver is to carry `NA` values over, | ||||||||
| #' but if you want to mimick [col2rgb()] you should set | ||||||||
| #' `na_value = 'transparent'`, i.e. treat `NA` as transparent white. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @return A numeric matrix with a row for each element in `colour` and either | ||||||||
| #' 3, 4, or 5 columns depending on the value of `alpha` and `to`. | ||||||||
| #' | ||||||||
| #' @family encoding and decoding functions | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # basic use | ||||||||
| #' decode_colour(c('#43e1f6', 'steelblue', '#67ce9fe4')) | ||||||||
| #' | ||||||||
| #' # Return alpha as well (no alpha value is interpreted as 1) | ||||||||
| #' decode_colour(c('#43e1f6', 'steelblue', '#67ce9fe4'), alpha = TRUE) | ||||||||
| #' | ||||||||
| #' # Decode directly into specific colour space | ||||||||
| #' decode_colour(c('#43e1f6', 'steelblue', '#67ce9fe4'), to = 'lch') | ||||||||
| #' | ||||||||
| decode_colour <- function(colour, alpha = FALSE, to = 'rgb', white = 'D65', na_value = NA) { | ||||||||
| if (to != 'rgb') { | ||||||||
| white <- as_white_ref(white) | ||||||||
| } | ||||||||
| alpha <- isTRUE(alpha) | ||||||||
| colours <- decode_c(colour, alpha, colourspace_match(to), white, na_value) | ||||||||
| colnames(colours) <- c(colour_dims[[to]], if (alpha) 'alpha' else NULL) | ||||||||
| colours | ||||||||
| } | ||||||||
| decode_c <- function(colour, alpha, to, white, na_value) { | ||||||||
| .Call('decode_c', as_colour_code(colour), alpha, as.integer(to), white, as.character(na_value), PACKAGE = 'farver') | ||||||||
| } | ||||||||
| farver/R/encode.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Encode colours into RGB hex-strings | ||||||||
| #' | ||||||||
| #' This is a version of [grDevices::rgb()] that works with the standard colour | ||||||||
| #' format used in farver (matrix or data.frame with colours in rows). It further | ||||||||
| #' support taking input from any colour space. | ||||||||
| #' | ||||||||
| #' @inheritSection convert_colour Handling of non-finite and out of bounds values | ||||||||
| #' | ||||||||
| #' @inheritParams convert_colour | ||||||||
| #' @param alpha A numeric vector between 0 and 1. Will be recycled to the number | ||||||||
| #' of rows in `colour`. If `NULL` or a single `NA` it will be ignored. | ||||||||
| #' @param from The input colour space. Allowed values are: `"cmy"`, | ||||||||
| #' `"cmyk"`, `"hsl"`, `"hsb"`, `"hsv"`, `"lab"` (CIE L*ab), `"hunterlab"` | ||||||||
| #' (Hunter Lab), `"lch"` (CIE Lch(ab) / polarLAB), `"luv"`, `"rgb"` (sRGB), | ||||||||
| #' `"xyz"`, `"yxy"` (CIE xyY), or `"hcl"` (CIE Lch(uv) / polarLuv) | ||||||||
| #' @param white The white reference of the input colour space. Will only have an | ||||||||
| #' effect for relative colour spaces such as Lab and luv. Any value accepted by | ||||||||
| #' [as_white_ref()] allowed. | ||||||||
| #' | ||||||||
| #' @return A character vector with colours encoded as `#RRGGBB(AA)` | ||||||||
| #' | ||||||||
| #' @family encoding and decoding functions | ||||||||
| #' | ||||||||
| #' @note The output may differ slightly from that of [grDevices::rgb()] since | ||||||||
| #' `rgb()` doesn't round numeric values correctly. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' spectrum <- decode_colour(rainbow(10)) | ||||||||
| #' | ||||||||
| #' encode_colour(spectrum) | ||||||||
| #' | ||||||||
| #' # Attach alpha values | ||||||||
| #' encode_colour(spectrum, alpha = c(0.5, 1)) | ||||||||
| #' | ||||||||
| #' # Encode from a different colour space | ||||||||
| #' spectrum_hcl <- convert_colour(spectrum, 'rgb', 'hcl') | ||||||||
| #' encode_colour(spectrum_hcl, from = 'hcl') | ||||||||
| #' | ||||||||
| encode_colour <- function(colour, alpha = NULL, from = 'rgb', white = 'D65') { | ||||||||
| if (from != 'rgb') { | ||||||||
| white <- as_white_ref(white) | ||||||||
| } | ||||||||
| encode_c(colour, alpha, colourspace_match(from), white) | ||||||||
| } | ||||||||
| encode_c <- function(colour, alpha, from, white) { | ||||||||
| if (!is.null(alpha)) { | ||||||||
| alpha <- alpha * 255 | ||||||||
| if (length(alpha) != 1) { | ||||||||
| alpha = rep_len(alpha, nrow(colour)) | ||||||||
| } else if (is.na(alpha) || alpha == 1) { | ||||||||
| alpha = NULL | ||||||||
| } | ||||||||
| } | ||||||||
| .Call('encode_c', as.matrix(colour), alpha, as.integer(from), white, PACKAGE = 'farver') | ||||||||
| } | ||||||||
| scales/R/utils.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| # Evaluates all arguments (see #81) | ||||||||
| force_all <- function(...) list(...) | ||||||||
| range_finite <- function(x) { | ||||||||
| suppressWarnings(range(x, na.rm = TRUE, finite = TRUE)) | ||||||||
| } | ||||||||
| seq2 <- function(from, to) { | ||||||||
| if (from > to) { | ||||||||
| numeric() | ||||||||
| } else { | ||||||||
| from:to | ||||||||
| } | ||||||||
| } | ||||||||
| demo_ggplot <- function(x, scale_name, ...) { | ||||||||
| call <- substitute(list(...)) | ||||||||
| call[[1]] <- as.name(scale_name) | ||||||||
| cat(paste0(deparse(call), "\n", collapse = "")) | ||||||||
| if (!requireNamespace("ggplot2", quietly = TRUE)) { | ||||||||
| message("Skipping; ggplot2 not installed") | ||||||||
| return(invisible()) | ||||||||
| } | ||||||||
| scale <- getExportedValue("ggplot2", scale_name) | ||||||||
| df <- data.frame(x = x, stringsAsFactors = FALSE) | ||||||||
| ggplot2::ggplot(df, ggplot2::aes(x, 1)) + | ||||||||
| ggplot2::geom_blank() + | ||||||||
| scale(NULL, ...) + | ||||||||
| ggplot2::scale_y_continuous(NULL, breaks = NULL) + | ||||||||
| ggplot2::theme(aspect.ratio = 1 / 5) | ||||||||
| } | ||||||||
| #' Demonstrate scales functions with ggplot2 code | ||||||||
| #' | ||||||||
| #' These functions generate ggplot2 code needed to use scales functions for | ||||||||
| #' real code. | ||||||||
| #' | ||||||||
| #' @param x A vector of data | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| demo_continuous <- function(x, ...) { | ||||||||
| demo_ggplot(x, "scale_x_continuous", ...) | ||||||||
| } | ||||||||
| #' @rdname demo_continuous | ||||||||
| #' @export | ||||||||
| demo_log10 <- function(x, ...) { | ||||||||
| demo_ggplot(x, "scale_x_log10", ...) | ||||||||
| } | ||||||||
| #' @rdname demo_continuous | ||||||||
| #' @export | ||||||||
| demo_discrete <- function(x, ...) { | ||||||||
| demo_ggplot(x, "scale_x_discrete", ...) | ||||||||
| } | ||||||||
| #' @rdname demo_continuous | ||||||||
| #' @export | ||||||||
| demo_datetime <- function(x, ...) { | ||||||||
| demo_ggplot(x, "scale_x_datetime", ...) | ||||||||
| } | ||||||||
| #' @rdname demo_continuous | ||||||||
| #' @export | ||||||||
| demo_time <- function(x, ...) { | ||||||||
| demo_ggplot(x, "scale_x_time", ...) | ||||||||
| } | ||||||||
| vctrs/R/names.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Retrieve and repair names | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' `vec_as_names()` takes a character vector of names and repairs it | ||||||||
| #' according to the `repair` argument. It is the r-lib and tidyverse | ||||||||
| #' equivalent of [base::make.names()]. | ||||||||
| #' | ||||||||
| #' vctrs deals with a few levels of name repair: | ||||||||
| #' | ||||||||
| #' * `minimal` names exist. The `names` attribute is not `NULL`. The | ||||||||
| #' name of an unnamed element is `""` and never `NA`. For instance, | ||||||||
| #' `vec_as_names()` always returns minimal names and data frames | ||||||||
| #' created by the tibble package have names that are, at least, | ||||||||
| #' `minimal`. | ||||||||
| #' | ||||||||
| #' * `unique` names are `minimal`, have no duplicates, and can be used | ||||||||
| #' where a variable name is expected. Empty names, `...`, and | ||||||||
| #' `..` followed by a sequence of digits are banned. | ||||||||
| #' | ||||||||
| #' - All columns can be accessed by name via `df[["name"]]` and | ||||||||
| #' ``df$`name` `` and ``with(df, `name`)``. | ||||||||
| #' | ||||||||
| #' * `universal` names are `unique` and syntactic (see Details for | ||||||||
| #' more). | ||||||||
| #' | ||||||||
| #' - Names work everywhere, without quoting: `df$name` and `with(df, | ||||||||
| #' name)` and `lm(name1 ~ name2, data = df)` and | ||||||||
| #' `dplyr::select(df, name)` all work. | ||||||||
| #' | ||||||||
| #' `universal` implies `unique`, `unique` implies `minimal`. These | ||||||||
| #' levels are nested. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @param names A character vector. | ||||||||
| #' @param repair Either a string or a function. If a string, it must | ||||||||
| #' be one of `"check_unique"`, `"minimal"`, `"unique"`, or `"universal"`. | ||||||||
| #' If a function, it is invoked with a vector of minimal names and must | ||||||||
| #' return minimal names, otherwise an error is thrown. | ||||||||
| #' | ||||||||
| #' * Minimal names are never `NULL` or `NA`. When an element doesn't | ||||||||
| #' have a name, its minimal name is an empty string. | ||||||||
| #' | ||||||||
| #' * Unique names are unique. A suffix is appended to duplicate | ||||||||
| #' names to make them unique. | ||||||||
| #' | ||||||||
| #' * Universal names are unique and syntactic, meaning that you can | ||||||||
| #' safely use the names as variables without causing a syntax | ||||||||
| #' error. | ||||||||
| #' | ||||||||
| #' The `"check_unique"` option doesn't perform any name repair. | ||||||||
| #' Instead, an error is raised if the names don't suit the | ||||||||
| #' `"unique"` criteria. | ||||||||
| #' @param repair_arg If specified and `repair = "check_unique"`, any errors | ||||||||
| #' will include a hint to set the `repair_arg`. | ||||||||
| #' @param quiet By default, the user is informed of any renaming | ||||||||
| #' caused by repairing the names. This only concerns unique and | ||||||||
| #' universal repairing. Set `quiet` to `TRUE` to silence the | ||||||||
| #' messages. | ||||||||
| #' @inheritParams ellipsis::dots_empty | ||||||||
| #' | ||||||||
| #' @section `minimal` names: | ||||||||
| #' | ||||||||
| #' `minimal` names exist. The `names` attribute is not `NULL`. The | ||||||||
| #' name of an unnamed element is `""` and never `NA`. | ||||||||
| #' | ||||||||
| #' Examples: | ||||||||
| #' | ||||||||
| #' ``` | ||||||||
| #' Original names of a vector with length 3: NULL | ||||||||
| #' minimal names: "" "" "" | ||||||||
| #' | ||||||||
| #' Original names: "x" NA | ||||||||
| #' minimal names: "x" "" | ||||||||
| #' ``` | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @section `unique` names: | ||||||||
| #' | ||||||||
| #' `unique` names are `minimal`, have no duplicates, and can be used | ||||||||
| #' (possibly with backticks) in contexts where a variable is | ||||||||
| #' expected. Empty names, `...`, and `..` followed by a sequence of | ||||||||
| #' digits are banned. If a data frame has `unique` names, you can | ||||||||
| #' index it by name, and also access the columns by name. In | ||||||||
| #' particular, `df[["name"]]` and `` df$`name` `` and also ``with(df, | ||||||||
| #' `name`)`` always work. | ||||||||
| #' | ||||||||
| #' There are many ways to make names `unique`. We append a suffix of the form | ||||||||
| #' `...j` to any name that is `""` or a duplicate, where `j` is the position. | ||||||||
| #' We also change `..#` and `...` to `...#`. | ||||||||
| #' | ||||||||
| #' Example: | ||||||||
| #' | ||||||||
| #' ``` | ||||||||
| #' Original names: "" "x" "" "y" "x" "..2" "..." | ||||||||
| #' unique names: "...1" "x...2" "...3" "y" "x...5" "...6" "...7" | ||||||||
| #' ``` | ||||||||
| #' | ||||||||
| #' Pre-existing suffixes of the form `...j` are always stripped, prior | ||||||||
| #' to making names `unique`, i.e. reconstructing the suffixes. If this | ||||||||
| #' interacts poorly with your names, you should take control of name | ||||||||
| #' repair. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @section `universal` names: | ||||||||
| #' | ||||||||
| #' `universal` names are `unique` and syntactic, meaning they: | ||||||||
| #' | ||||||||
| #' * Are never empty (inherited from `unique`). | ||||||||
| #' * Have no duplicates (inherited from `unique`). | ||||||||
| #' * Are not `...`. Do not have the form `..i`, where `i` is a | ||||||||
| #' number (inherited from `unique`). | ||||||||
| #' * Consist of letters, numbers, and the dot `.` or underscore `_` | ||||||||
| #' characters. | ||||||||
| #' * Start with a letter or start with the dot `.` not followed by a | ||||||||
| #' number. | ||||||||
| #' * Are not a [reserved] word, e.g., `if` or `function` or `TRUE`. | ||||||||
| #' | ||||||||
| #' If a vector has `universal` names, variable names can be used | ||||||||
| #' "as is" in code. They work well with nonstandard evaluation, e.g., | ||||||||
| #' `df$name` works. | ||||||||
| #' | ||||||||
| #' vctrs has a different method of making names syntactic than | ||||||||
| #' [base::make.names()]. In general, vctrs prepends one or more dots | ||||||||
| #' `.` until the name is syntactic. | ||||||||
| #' | ||||||||
| #' Examples: | ||||||||
| #' | ||||||||
| #' ``` | ||||||||
| #' Original names: "" "x" NA "x" | ||||||||
| #' universal names: "...1" "x...2" "...3" "x...4" | ||||||||
| #' | ||||||||
| #' Original names: "(y)" "_z" ".2fa" "FALSE" | ||||||||
| #' universal names: ".y." "._z" "..2fa" ".FALSE" | ||||||||
| #' ``` | ||||||||
| #' | ||||||||
| #' @seealso [rlang::names2()] returns the names of an object, after | ||||||||
| #' making them `minimal`. | ||||||||
| #' | ||||||||
| #' The [Names attribute](https://principles.tidyverse.org/names-attribute.html) | ||||||||
| #' section in the "tidyverse package development principles". | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # By default, `vec_as_names()` returns minimal names: | ||||||||
| #' vec_as_names(c(NA, NA, "foo")) | ||||||||
| #' | ||||||||
| #' # You can make them unique: | ||||||||
| #' vec_as_names(c(NA, NA, "foo"), repair = "unique") | ||||||||
| #' | ||||||||
| #' # Universal repairing fixes any non-syntactic name: | ||||||||
| #' vec_as_names(c("_foo", "+"), repair = "universal") | ||||||||
| #' @export | ||||||||
| vec_as_names <- function(names, | ||||||||
| ..., | ||||||||
| repair = c("minimal", "unique", "universal", "check_unique"), | ||||||||
| repair_arg = "", | ||||||||
| quiet = FALSE) { | ||||||||
| if (!missing(...)) { | ||||||||
| ellipsis::check_dots_empty() | ||||||||
| } | ||||||||
| .Call(vctrs_as_names, names, repair, repair_arg, quiet) | ||||||||
| } | ||||||||
| validate_name_repair_arg <- function(repair) { | ||||||||
| .Call(vctrs_validate_name_repair_arg, repair) | ||||||||
| } | ||||||||
| validate_minimal_names <- function(names, n = NULL) { | ||||||||
| .Call(vctrs_validate_minimal_names, names, n) | ||||||||
| } | ||||||||
| validate_unique <- function(names, arg = "", n = NULL) { | ||||||||
| validate_minimal_names(names, n) | ||||||||
| empty_names <- detect_empty_names(names) | ||||||||
| if (has_length(empty_names)) { | ||||||||
| stop_names_cannot_be_empty(names) | ||||||||
| } | ||||||||
| dot_dot_name <- detect_dot_dot(names) | ||||||||
| if (has_length(dot_dot_name)) { | ||||||||
| stop_names_cannot_be_dot_dot(names) | ||||||||
| } | ||||||||
| if (anyDuplicated(names)) { | ||||||||
| stop_names_must_be_unique(names, arg) | ||||||||
| } | ||||||||
| invisible(names) | ||||||||
| } | ||||||||
| detect_empty_names <- function(names) { | ||||||||
| which(names == "") | ||||||||
| } | ||||||||
| detect_dot_dot <- function(names) { | ||||||||
| grep("^[.][.](?:[.]|[1-9][0-9]*)$", names) | ||||||||
| } | ||||||||
| #' Get or set the names of a vector | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' These functions work like [rlang::names2()], [names()] and [names<-()], | ||||||||
| #' except that they return or modify the the rowwise names of the vector. These are: | ||||||||
| #' * The usual `names()` for atomic vectors and lists | ||||||||
| #' * The row names for data frames and matrices | ||||||||
| #' * The names of the first dimension for arrays | ||||||||
| #' Rowwise names are size consistent: the length of the names always equals | ||||||||
| #' [vec_size()]. | ||||||||
| #' | ||||||||
| #' `vec_names2()` returns the repaired names from a vector, even if it is unnamed. | ||||||||
| #' See [vec_as_names()] for details on name repair. | ||||||||
| #' | ||||||||
| #' `vec_names()` is a bare-bones version that returns `NULL` if the vector is | ||||||||
| #' unnamed. | ||||||||
| #' | ||||||||
| #' `vec_set_names()` sets the names or removes them. | ||||||||
| #' | ||||||||
| #' @param x A vector with names | ||||||||
| #' @param names A character vector, or `NULL`. | ||||||||
| #' @inheritParams vec_as_names | ||||||||
| #' | ||||||||
| #' @return | ||||||||
| #' `vec_names2()` returns the names of `x`, repaired. | ||||||||
| #' `vec_names()` returns the names of `x` or `NULL` if unnamed. | ||||||||
| #' `vec_set_names()` returns `x` with names updated. | ||||||||
| #' | ||||||||
| #' @name vec_names | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' vec_names2(1:3) | ||||||||
| #' vec_names2(1:3, repair = "unique") | ||||||||
| #' vec_names2(c(a = 1, b = 2)) | ||||||||
| #' | ||||||||
| #' # `vec_names()` consistently returns the rowwise names of data frames and arrays: | ||||||||
| #' vec_names(data.frame(a = 1, b = 2)) | ||||||||
| #' names(data.frame(a = 1, b = 2)) | ||||||||
| #' vec_names(mtcars) | ||||||||
| #' names(mtcars) | ||||||||
| #' vec_names(Titanic) | ||||||||
| #' names(Titanic) | ||||||||
| #' | ||||||||
| #' vec_set_names(1:3, letters[1:3]) | ||||||||
| #' vec_set_names(data.frame(a = 1:3), letters[1:3]) | ||||||||
| vec_names2 <- function(x, | ||||||||
| ..., | ||||||||
| repair = c("minimal", "unique", "universal", "check_unique"), | ||||||||
| quiet = FALSE) { | ||||||||
| if (!missing(...)) { | ||||||||
| ellipsis::check_dots_empty() | ||||||||
| } | ||||||||
| repair <- validate_name_repair_arg(repair) | ||||||||
| if (is_function(repair)) { | ||||||||
| names <- minimal_names(x) | ||||||||
| new_names <- validate_minimal_names(repair(names), n = length(names)) | ||||||||
| if (!quiet) { | ||||||||
| describe_repair(names, new_names) | ||||||||
| } | ||||||||
| return(new_names) | ||||||||
| } | ||||||||
| switch(repair, | ||||||||
| minimal = minimal_names(x), | ||||||||
| unique = unique_names(x, quiet = quiet), | ||||||||
| universal = as_universal_names(minimal_names(x), quiet = quiet), | ||||||||
| check_unique = validate_unique(minimal_names(x)) | ||||||||
| ) | ||||||||
| } | ||||||||
| vec_repair_names <- function(x, | ||||||||
| repair = c("minimal", "unique", "universal", "check_unique"), | ||||||||
| ..., | ||||||||
| quiet = FALSE) { | ||||||||
| if (is.data.frame(x)) { | ||||||||
| x | ||||||||
| } else { | ||||||||
| vec_set_names(x, vec_names2(x, ..., repair = repair, quiet = quiet)) | ||||||||
| } | ||||||||
| } | ||||||||
| minimal_names <- function(x) { | ||||||||
| .Call(vctrs_minimal_names, x) | ||||||||
| } | ||||||||
| unique_names <- function(x, quiet = FALSE) { | ||||||||
| .Call(vctrs_unique_names, x, quiet) | ||||||||
| } | ||||||||
| #' @rdname vec_names | ||||||||
| #' @export | ||||||||
| vec_names <- function(x) { | ||||||||
| .Call(vctrs_names, x) | ||||||||
| } | ||||||||
| as_minimal_names <- function(names) { | ||||||||
| .Call(vctrs_as_minimal_names, names) | ||||||||
| } | ||||||||
| as_unique_names <- function(names, quiet = FALSE) { | ||||||||
| .Call(vctrs_as_unique_names, names, quiet) | ||||||||
| } | ||||||||
| as_universal_names <- function(names, quiet = FALSE) { | ||||||||
| new_names <- names | ||||||||
| new_names[] <- "" | ||||||||
| naked_names <- strip_pos(two_to_three_dots(names)) | ||||||||
| empty <- naked_names %in% c("", "...") | ||||||||
| new_names[!empty] <- make_syntactic(naked_names[!empty]) | ||||||||
| needs_suffix <- empty | vec_duplicate_detect(new_names) | ||||||||
| new_names <- append_pos(new_names, needs_suffix = needs_suffix) | ||||||||
| if (!quiet) { | ||||||||
| describe_repair(names, new_names) | ||||||||
| } | ||||||||
| new_names | ||||||||
| } | ||||||||
| two_to_three_dots <- function(names) { | ||||||||
| sub("(^[.][.][1-9][0-9]*$)", ".\\1", names) | ||||||||
| } | ||||||||
| append_pos <- function(names, needs_suffix) { | ||||||||
| need_append_pos <- which(needs_suffix) | ||||||||
| names[need_append_pos] <- paste0(names[need_append_pos], "...", need_append_pos) | ||||||||
| names | ||||||||
| } | ||||||||
| strip_pos <- function(names) { | ||||||||
| rx <- "([.][.][.][1-9][0-9]*)+$" | ||||||||
| gsub(rx, "", names) %|% "" | ||||||||
| } | ||||||||
| # Makes each individual name syntactic but does not enforce unique-ness | ||||||||
| make_syntactic <- function(names) { | ||||||||
| names[is.na(names)] <- "" | ||||||||
| names[names == ""] <- "." | ||||||||
| names[names == "..."] <- "...." | ||||||||
| names <- sub("^_", "._", names) | ||||||||
| new_names <- make.names(names) | ||||||||
| X_prefix <- grepl("^X", new_names) & !grepl("^X", names) | ||||||||
| new_names[X_prefix] <- sub("^X", "", new_names[X_prefix]) | ||||||||
| dot_suffix <- which(new_names == paste0(names, ".")) | ||||||||
| new_names[dot_suffix] <- sub("^(.*)[.]$", ".\\1", new_names[dot_suffix]) | ||||||||
| # Illegal characters have been replaced with '.' via make.names() | ||||||||
| # however, we have: | ||||||||
| # * Declined its addition of 'X' prefixes. | ||||||||
| # * Turned its '.' suffixes to '.' prefixes. | ||||||||
| regex <- paste0( | ||||||||
| "^(?<leading_dots>[.]{0,2})", | ||||||||
| "(?<numbers>[0-9]*)", | ||||||||
| "(?<leftovers>[^0-9]?.*$)" | ||||||||
| ) | ||||||||
| re <- re_match(new_names, pattern = regex) | ||||||||
| needs_dots <- which(re$numbers != "") | ||||||||
| needs_third_dot <- (re$leftovers[needs_dots] == "") | ||||||||
| re$leading_dots[needs_dots] <- ifelse(needs_third_dot, "...", "..") | ||||||||
| new_names <- paste0(re$leading_dots, re$numbers, re$leftovers) | ||||||||
| new_names | ||||||||
| } | ||||||||
| # From rematch2, except we don't add tbl_df or tbl classes to the return value | ||||||||
| re_match <- function(text, pattern, perl = TRUE, ...) { | ||||||||
| stopifnot( | ||||||||
| is.character(pattern), | ||||||||
| length(pattern) == 1, | ||||||||
| !is.na(pattern) | ||||||||
| ) | ||||||||
| text <- as.character(text) | ||||||||
| match <- regexpr(pattern, text, perl = perl, ...) | ||||||||
| start <- as.vector(match) | ||||||||
| length <- attr(match, "match.length") | ||||||||
| end <- start + length - 1L | ||||||||
| matchstr <- substring(text, start, end) | ||||||||
| matchstr[ start == -1 ] <- NA_character_ | ||||||||
| res <- data.frame( | ||||||||
| stringsAsFactors = FALSE, | ||||||||
| .text = text, | ||||||||
| .match = matchstr | ||||||||
| ) | ||||||||
| if (!is.null(attr(match, "capture.start"))) { | ||||||||
| gstart <- attr(match, "capture.start") | ||||||||
| glength <- attr(match, "capture.length") | ||||||||
| gend <- gstart + glength - 1L | ||||||||
| groupstr <- substring(text, gstart, gend) | ||||||||
| groupstr[ gstart == -1 ] <- NA_character_ | ||||||||
| dim(groupstr) <- dim(gstart) | ||||||||
| res <- cbind(groupstr, res, stringsAsFactors = FALSE) | ||||||||
| } | ||||||||
| names(res) <- c(attr(match, "capture.names"), ".text", ".match") | ||||||||
| res | ||||||||
| } | ||||||||
| describe_repair <- function(orig_names, names) { | ||||||||
| if (is_null(orig_names)) { | ||||||||
| orig_names <- rep_along(names, "") | ||||||||
| } | ||||||||
| if (length(orig_names) != length(names)) { | ||||||||
| stop("Internal error: New names and old names don't have same length") | ||||||||
| } | ||||||||
| new_names <- names != as_minimal_names(orig_names) | ||||||||
| if (any(new_names)) { | ||||||||
| msg <- bullets( | ||||||||
| header = "New names:", | ||||||||
| paste0( | ||||||||
| tick_if_needed(orig_names[new_names]), | ||||||||
| " -> ", | ||||||||
| tick_if_needed(names[new_names]) | ||||||||
| ) | ||||||||
| ) | ||||||||
| message(msg) | ||||||||
| } | ||||||||
| } | ||||||||
| bullets <- function(..., header = NULL) { | ||||||||
| problems <- c(...) | ||||||||
| MAX_BULLETS <- 6L | ||||||||
| if (length(problems) >= MAX_BULLETS) { | ||||||||
| n_more <- length(problems) - MAX_BULLETS + 1L | ||||||||
| problems[[MAX_BULLETS]] <- "..." | ||||||||
| length(problems) <- MAX_BULLETS | ||||||||
| } | ||||||||
| info <- paste0("* ", problems, collapse = "\n") | ||||||||
| if (!is.null(header)) { | ||||||||
| info <- paste0(header, "\n", info) | ||||||||
| } | ||||||||
| info | ||||||||
| } | ||||||||
| tick <- function(x) { | ||||||||
| ifelse(is.na(x), "NA", encodeString(x, quote = "`")) | ||||||||
| } | ||||||||
| is_syntactic <- function(x) { | ||||||||
| ret <- (make_syntactic(x) == x) | ||||||||
| ret[is.na(x)] <- FALSE | ||||||||
| ret | ||||||||
| } | ||||||||
| tick_if_needed <- function(x) { | ||||||||
| needs_ticks <- !is_syntactic(x) | ||||||||
| x[needs_ticks] <- tick(x[needs_ticks]) | ||||||||
| x | ||||||||
| } | ||||||||
| # Used in names.c | ||||||||
| set_rownames_fallback <- function(x, names) { | ||||||||
| rownames(x) <- names | ||||||||
| x | ||||||||
| } | ||||||||
| # Used in names.c | ||||||||
| set_names_fallback <- function(x, names) { | ||||||||
| names(x) <- names | ||||||||
| x | ||||||||
| } | ||||||||
| #' @rdname vec_names | ||||||||
| #' @export | ||||||||
| vec_set_names <- function(x, names) { | ||||||||
| .Call(vctrs_set_names, x, names) | ||||||||
| } | ||||||||
| #' Repair names with legacy method | ||||||||
| #' | ||||||||
| #' This standardises names with the legacy approach that was used in | ||||||||
| #' tidyverse packages (such as tibble, tidyr, and readxl) before | ||||||||
| #' [vec_as_names()] was implemented. This tool is meant to help | ||||||||
| #' transitioning to the new name repairing standard and will be | ||||||||
| #' deprecated and removed from the package some time in the future. | ||||||||
| #' | ||||||||
| #' @inheritParams vec_as_names | ||||||||
| #' @param prefix,sep Prefix and separator for repaired names. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' if (rlang::is_installed("tibble")) { | ||||||||
| #' | ||||||||
| #' library(tibble) | ||||||||
| #' | ||||||||
| #' # Names repair is turned off by default in tibble: | ||||||||
| #' try(tibble(a = 1, a = 2)) | ||||||||
| #' | ||||||||
| #' # You can turn it on by supplying a repair method: | ||||||||
| #' tibble(a = 1, a = 2, .name_repair = "universal") | ||||||||
| #' | ||||||||
| #' # If you prefer the legacy method, use `vec_as_names_legacy()`: | ||||||||
| #' tibble(a = 1, a = 2, .name_repair = vec_as_names_legacy) | ||||||||
| #' | ||||||||
| #' } | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| vec_as_names_legacy <- function(names, prefix = "V", sep = "") { | ||||||||
| if (length(names) == 0) { | ||||||||
| return(character()) | ||||||||
| } | ||||||||
| blank <- names == "" | ||||||||
| names[!blank] <- make.unique(names[!blank], sep = sep) | ||||||||
| new_nms <- setdiff(paste(prefix, seq_along(names), sep = sep), names) | ||||||||
| names[blank] <- new_nms[seq_len(sum(blank))] | ||||||||
| names | ||||||||
| } | ||||||||
| #' Name specifications | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' A name specification describes how to combine an inner and outer | ||||||||
| #' names. This sort of name combination arises when concatenating | ||||||||
| #' vectors or flattening lists. There are two possible cases: | ||||||||
| #' | ||||||||
| #' * Named vector: | ||||||||
| #' | ||||||||
| #' ``` | ||||||||
| #' vec_c(outer = c(inner1 = 1, inner2 = 2)) | ||||||||
| #' ``` | ||||||||
| #' | ||||||||
| #' * Unnamed vector: | ||||||||
| #' | ||||||||
| #' ``` | ||||||||
| #' vec_c(outer = 1:2) | ||||||||
| #' ``` | ||||||||
| #' | ||||||||
| #' In r-lib and tidyverse packages, these cases are errors by default, | ||||||||
| #' because there's no behaviour that works well for every case. | ||||||||
| #' Instead, you can provide a name specification that describes how to | ||||||||
| #' combine the inner and outer names of inputs. Name specifications | ||||||||
| #' can refer to: | ||||||||
| #' | ||||||||
| #' * `outer`: The external name recycled to the size of the input | ||||||||
| #' vector. | ||||||||
| #' | ||||||||
| #' * `inner`: Either the names of the input vector, or a sequence of | ||||||||
| #' integer from 1 to the size of the vector if it is unnamed. | ||||||||
| #' | ||||||||
| #' @param name_spec,.name_spec A name specification for combining | ||||||||
| #' inner and outer names. This is relevant for inputs passed with a | ||||||||
| #' name, when these inputs are themselves named, like `outer = | ||||||||
| #' c(inner = 1)`, or when they have length greater than 1: `outer = | ||||||||
| #' 1:2`. By default, these cases trigger an error. You can resolve | ||||||||
| #' the error by providing a specification that describes how to | ||||||||
| #' combine the names or the indices of the inner vector with the | ||||||||
| #' name of the input. This specification can be: | ||||||||
| #' | ||||||||
| #' * A function of two arguments. The outer name is passed as a | ||||||||
| #' string to the first argument, and the inner names or positions | ||||||||
| #' are passed as second argument. | ||||||||
| #' | ||||||||
| #' * An anonymous function as a purrr-style formula. | ||||||||
| #' | ||||||||
| #' * A glue specification of the form `"{outer}_{inner}"`. | ||||||||
| #' | ||||||||
| #' * An [rlang::zap()] object, in which case both outer and inner | ||||||||
| #' names are ignored and the result is unnamed. | ||||||||
| #' | ||||||||
| #' See the [name specification topic][name_spec]. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # By default, named inputs must be length 1: | ||||||||
| #' vec_c(name = 1) # ok | ||||||||
| #' try(vec_c(name = 1:3)) # bad | ||||||||
| #' | ||||||||
| #' # They also can't have internal names, even if scalar: | ||||||||
| #' try(vec_c(name = c(internal = 1))) # bad | ||||||||
| #' | ||||||||
| #' # Pass a name specification to work around this. A specification | ||||||||
| #' # can be a glue string referring to `outer` and `inner`: | ||||||||
| #' vec_c(name = 1:3, other = 4:5, .name_spec = "{outer}") | ||||||||
| #' vec_c(name = 1:3, other = 4:5, .name_spec = "{outer}_{inner}") | ||||||||
| #' | ||||||||
| #' # They can also be functions: | ||||||||
| #' my_spec <- function(outer, inner) paste(outer, inner, sep = "_") | ||||||||
| #' vec_c(name = 1:3, other = 4:5, .name_spec = my_spec) | ||||||||
| #' | ||||||||
| #' # Or purrr-style formulas for anonymous functions: | ||||||||
| #' vec_c(name = 1:3, other = 4:5, .name_spec = ~ paste0(.x, .y)) | ||||||||
| #' @name name_spec | ||||||||
| NULL | ||||||||
| apply_name_spec <- function(name_spec, outer, inner, n = length(inner)) { | ||||||||
| .Call(vctrs_apply_name_spec, name_spec, outer, inner, n) | ||||||||
| } | ||||||||
| glue_as_name_spec <- function(`_spec`) { | ||||||||
| function(inner, outer) { | ||||||||
| glue::glue(`_spec`) | ||||||||
| } | ||||||||
| } | ||||||||
| # Evaluate glue specs in a child of base for now | ||||||||
| environment(glue_as_name_spec) <- baseenv() | ||||||||
| ggplot2/R/aes-evaluation.r | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Control aesthetic evaluation | ||||||||
| #' | ||||||||
| #' Most aesthetics are mapped from variables found in the data. Sometimes, | ||||||||
| #' however, you want to delay the mapping until later in the rendering process. | ||||||||
| #' ggplot2 has three stages of the data that you can map aesthetics from. The | ||||||||
| #' default is to map at the beginning, using the layer data provided by the | ||||||||
| #' user. The second stage is after the data has been transformed by the layer | ||||||||
| #' stat. The third and last stage is after the data has been transformed and | ||||||||
| #' mapped by the plot scales. The most common example of mapping from stat | ||||||||
| #' transformed data is the height of bars in [geom_histogram()]: | ||||||||
| #' the height does not come from a variable in the underlying data, but | ||||||||
| #' is instead mapped to the `count` computed by [stat_bin()]. An example of | ||||||||
| #' mapping from scaled data could be to use a desaturated version of the stroke | ||||||||
| #' colour for fill. If you want to map directly from the layer data you should | ||||||||
| #' not do anything special. In order to map from stat transformed data you | ||||||||
| #' should use the `after_stat()` function to flag that evaluation of the | ||||||||
| #' aesthetic mapping should be postponed until after stat transformation. | ||||||||
| #' Similarly, you should use `after_scale()` to flag evaluation of mapping for | ||||||||
| #' after data has been scaled. If you want to map the same aesthetic multiple | ||||||||
| #' times, e.g. map `x` to a data column for the stat, but remap it for the geom, | ||||||||
| #' you can use the `stage()` function to collect multiple mappings. | ||||||||
| #' | ||||||||
| #' `after_stat()` replaces the old approaches of using either `stat()` or | ||||||||
| #' surrounding the variable names with `..`. | ||||||||
| #' | ||||||||
| #' @note Evaluation after stat transformation will only have access to the | ||||||||
| #' variables calculated by the stat. Evaluation after scaling will only have | ||||||||
| #' access to the final aesthetics of the layer (including non-mapped, default | ||||||||
| #' aesthetics). The original layer data can only be accessed at the first stage. | ||||||||
| #' | ||||||||
| #' @param x An aesthetic expression using variables calculated by the stat | ||||||||
| #' (`after_stat()`) or layer aesthetics (`after_scale()`). | ||||||||
| #' @param start An aesthetic expression using variables from the layer data. | ||||||||
| #' @param after_stat An aesthetic expression using variables calculated by the | ||||||||
| #' stat. | ||||||||
| #' @param after_scale An aesthetic expression using layer aesthetics. | ||||||||
| #' | ||||||||
| #' @rdname aes_eval | ||||||||
| #' @name aes_eval | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # Default histogram display | ||||||||
| #' ggplot(mpg, aes(displ)) + | ||||||||
| #' geom_histogram(aes(y = after_stat(count))) | ||||||||
| #' | ||||||||
| #' # Scale tallest bin to 1 | ||||||||
| #' ggplot(mpg, aes(displ)) + | ||||||||
| #' geom_histogram(aes(y = after_stat(count / max(count)))) | ||||||||
| #' | ||||||||
| #' # Use a transparent version of colour for fill | ||||||||
| #' ggplot(mpg, aes(class, hwy)) + | ||||||||
| #' geom_boxplot(aes(colour = class, fill = after_scale(alpha(colour, 0.4)))) | ||||||||
| #' | ||||||||
| #' # Use stage to modify the scaled fill | ||||||||
| #' ggplot(mpg, aes(class, hwy)) + | ||||||||
| #' geom_boxplot(aes(fill = stage(class, after_scale = alpha(fill, 0.4)))) | ||||||||
| NULL | ||||||||
| #' @rdname aes_eval | ||||||||
| #' @export | ||||||||
| after_stat <- function(x) { | ||||||||
| x | ||||||||
| } | ||||||||
| #' @rdname aes_eval | ||||||||
| #' @usage NULL | ||||||||
| #' @export | ||||||||
| stat <- function(x) { | ||||||||
| x | ||||||||
| } | ||||||||
| #' @rdname aes_eval | ||||||||
| #' @export | ||||||||
| after_scale <- function(x) { | ||||||||
| x | ||||||||
| } | ||||||||
| #' @rdname aes_eval | ||||||||
| #' @export | ||||||||
| stage <- function(start = NULL, after_stat = NULL, after_scale = NULL) { | ||||||||
| start | ||||||||
| } | ||||||||
| stage_calculated <- function(start = NULL, after_stat = NULL, after_scale = NULL) { | ||||||||
| after_stat | ||||||||
| } | ||||||||
| stage_scaled <- function(start = NULL, after_stat = NULL, after_scale = NULL) { | ||||||||
| after_scale | ||||||||
| } | ||||||||
| # Regex to determine if an identifier refers to a calculated aesthetic | ||||||||
| match_calculated_aes <- "^\\.\\.([a-zA-Z._]+)\\.\\.$" | ||||||||
| is_dotted_var <- function(x) { | ||||||||
| grepl(match_calculated_aes, x) | ||||||||
| } | ||||||||
| # Determine if aesthetic is calculated | ||||||||
| is_calculated_aes <- function(aesthetics) { | ||||||||
| vapply(aesthetics, is_calculated, logical(1), USE.NAMES = FALSE) | ||||||||
| } | ||||||||
| is_scaled_aes <- function(aesthetics) { | ||||||||
| vapply(aesthetics, is_scaled, logical(1), USE.NAMES = FALSE) | ||||||||
| } | ||||||||
| is_staged_aes <- function(aesthetics) { | ||||||||
| vapply(aesthetics, is_staged, logical(1), USE.NAMES = FALSE) | ||||||||
| } | ||||||||
| is_calculated <- function(x) { | ||||||||
| if (is_call(get_expr(x), "after_stat")) { | ||||||||
| return(TRUE) | ||||||||
| } | ||||||||
| # Support of old recursive behaviour | ||||||||
| if (is.atomic(x)) { | ||||||||
| FALSE | ||||||||
| } else if (is.symbol(x)) { | ||||||||
| is_dotted_var(as.character(x)) | ||||||||
| } else if (is_quosure(x)) { | ||||||||
| is_calculated(quo_get_expr(x)) | ||||||||
| } else if (is.call(x)) { | ||||||||
| if (identical(x[[1]], quote(stat))) { | ||||||||
| TRUE | ||||||||
| } else { | ||||||||
| any(vapply(x, is_calculated, logical(1))) | ||||||||
| } | ||||||||
| } else if (is.pairlist(x)) { | ||||||||
| FALSE | ||||||||
| } else { | ||||||||
| abort(glue("Unknown input: {class(x)[1]}")) | ||||||||
| } | ||||||||
| } | ||||||||
| is_scaled <- function(x) { | ||||||||
| is_call(get_expr(x), "after_scale") | ||||||||
| } | ||||||||
| is_staged <- function(x) { | ||||||||
| is_call(get_expr(x), "stage") | ||||||||
| } | ||||||||
| # Strip dots from expressions | ||||||||
| strip_dots <- function(expr, env, strip_pronoun = FALSE) { | ||||||||
| if (is.atomic(expr)) { | ||||||||
| expr | ||||||||
| } else if (is.name(expr)) { | ||||||||
| expr_ch <- as.character(expr) | ||||||||
| if (nchar(expr_ch) > 0) { | ||||||||
| as.name(gsub(match_calculated_aes, "\\1", expr_ch)) | ||||||||
| } else { | ||||||||
| expr | ||||||||
| } | ||||||||
| } else if (is_quosure(expr)) { | ||||||||
| # strip dots from quosure and reconstruct the quosure | ||||||||
| new_quosure( | ||||||||
| strip_dots(quo_get_expr(expr), env = quo_get_env(expr), strip_pronoun = strip_pronoun), | ||||||||
| quo_get_env(expr) | ||||||||
| ) | ||||||||
| } else if (is.call(expr)) { | ||||||||
| if (strip_pronoun && is_call(expr, "$") && is_symbol(expr[[2]], ".data")) { | ||||||||
| strip_dots(expr[[3]], env, strip_pronoun = strip_pronoun) | ||||||||
| } else if (strip_pronoun && is_call(expr, "[[") && is_symbol(expr[[2]], ".data")) { | ||||||||
| tryCatch( | ||||||||
| sym(eval(expr[[3]], env)), | ||||||||
| error = function(e) expr[[3]] | ||||||||
| ) | ||||||||
| } else if (is_call(expr, "stat")) { | ||||||||
| strip_dots(expr[[2]], env, strip_pronoun = strip_pronoun) | ||||||||
| } else { | ||||||||
| expr[-1] <- lapply(expr[-1], strip_dots, env = env, strip_pronoun = strip_pronoun) | ||||||||
| expr | ||||||||
| } | ||||||||
| } else if (is.pairlist(expr)) { | ||||||||
| # In the unlikely event of an anonymous function | ||||||||
| as.pairlist(lapply(expr, strip_dots, env = env, strip_pronoun = strip_pronoun)) | ||||||||
| } else if (is.list(expr)) { | ||||||||
| # For list of aesthetics | ||||||||
| lapply(expr, strip_dots, env = env, strip_pronoun = strip_pronoun) | ||||||||
| } else { | ||||||||
| abort(glue("Unknown input: {class(expr)[1]}")) | ||||||||
| } | ||||||||
| } | ||||||||
| strip_stage <- function(expr) { | ||||||||
| uq_expr <- get_expr(expr) | ||||||||
| if (is_call(uq_expr, c("after_stat", "after_scale"))) { | ||||||||
| uq_expr[[2]] | ||||||||
| } else if (is_call(uq_expr, "stage")) { | ||||||||
| # Prefer stat mapping if present, otherwise original mapping (fallback to | ||||||||
| # scale mapping) but there should always be two arguments to stage() | ||||||||
| uq_expr$after_stat %||% uq_expr$start %||% (if (is.null(uq_expr$after_scale)) uq_expr[[3]]) %||% uq_expr[[2]] | ||||||||
| } else { | ||||||||
| expr | ||||||||
| } | ||||||||
| } | ||||||||
| # Convert aesthetic mapping into text labels | ||||||||
| make_labels <- function(mapping) { | ||||||||
| default_label <- function(aesthetic, mapping) { | ||||||||
| # e.g., geom_smooth(aes(colour = "loess")) or aes(y = NULL) | ||||||||
| if (is.atomic(mapping)) { | ||||||||
| return(aesthetic) | ||||||||
| } | ||||||||
| mapping <- strip_stage(mapping) | ||||||||
| mapping <- strip_dots(mapping, strip_pronoun = TRUE) | ||||||||
| if (is_quosure(mapping) && quo_is_symbol(mapping)) { | ||||||||
| name <- as_string(quo_get_expr(mapping)) | ||||||||
| } else { | ||||||||
| name <- quo_text(mapping) | ||||||||
| name <- gsub("\n.*$", "...", name) | ||||||||
| } | ||||||||
| name | ||||||||
| } | ||||||||
| Map(default_label, names(mapping), mapping) | ||||||||
| } | ||||||||
| rlang/R/expr.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Is an object an expression? | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' `is_expression()` tests for expressions, the set of objects that can be | ||||||||
| #' obtained from parsing R code. An expression can be one of two | ||||||||
| #' things: either a symbolic object (for which `is_symbolic()` returns | ||||||||
| #' `TRUE`), or a syntactic literal (testable with | ||||||||
| #' `is_syntactic_literal()`). Technically, calls can contain any R | ||||||||
| #' object, not necessarily symbolic objects or syntactic | ||||||||
| #' literals. However, this only happens in artificial | ||||||||
| #' situations. Expressions as we define them only contain numbers, | ||||||||
| #' strings, `NULL`, symbols, and calls: this is the complete set of R | ||||||||
| #' objects that can be created when R parses source code (e.g. from | ||||||||
| #' using [parse_expr()]). | ||||||||
| #' | ||||||||
| #' Note that we are using the term expression in its colloquial sense | ||||||||
| #' and not to refer to [expression()] vectors, a data type that wraps | ||||||||
| #' expressions in a vector and which isn't used much in modern R code. | ||||||||
| #' | ||||||||
| #' @details | ||||||||
| #' | ||||||||
| #' `is_symbolic()` returns `TRUE` for symbols and calls (objects with | ||||||||
| #' type `language`). Symbolic objects are replaced by their value | ||||||||
| #' during evaluation. Literals are the complement of symbolic | ||||||||
| #' objects. They are their own value and return themselves during | ||||||||
| #' evaluation. | ||||||||
| #' | ||||||||
| #' `is_syntactic_literal()` is a predicate that returns `TRUE` for the | ||||||||
| #' subset of literals that are created by R when parsing text (see | ||||||||
| #' [parse_expr()]): numbers, strings and `NULL`. Along with symbols, | ||||||||
| #' these literals are the terminating nodes in an AST. | ||||||||
| #' | ||||||||
| #' Note that in the most general sense, a literal is any R object that | ||||||||
| #' evaluates to itself and that can be evaluated in the empty | ||||||||
| #' environment. For instance, `quote(c(1, 2))` is not a literal, it is | ||||||||
| #' a call. However, the result of evaluating it in [base_env()] is a | ||||||||
| #' literal(in this case an atomic vector). | ||||||||
| #' | ||||||||
| #' Pairlists are also a kind of language objects. However, since they | ||||||||
| #' are mostly an internal data structure, `is_expression()` returns `FALSE` | ||||||||
| #' for pairlists. You can use `is_pairlist()` to explicitly check for | ||||||||
| #' them. Pairlists are the data structure for function arguments. They | ||||||||
| #' usually do not arise from R code because subsetting a call is a | ||||||||
| #' type-preserving operation. However, you can obtain the pairlist of | ||||||||
| #' arguments by taking the CDR of the call object from C code. The | ||||||||
| #' rlang function [node_cdr()] will do it from R. Another way in | ||||||||
| #' which pairlist of arguments arise is by extracting the argument | ||||||||
| #' list of a closure with [base::formals()] or [fn_fmls()]. | ||||||||
| #' | ||||||||
| #' @param x An object to test. | ||||||||
| #' @seealso [is_call()] for a call predicate. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' q1 <- quote(1) | ||||||||
| #' is_expression(q1) | ||||||||
| #' is_syntactic_literal(q1) | ||||||||
| #' | ||||||||
| #' q2 <- quote(x) | ||||||||
| #' is_expression(q2) | ||||||||
| #' is_symbol(q2) | ||||||||
| #' | ||||||||
| #' q3 <- quote(x + 1) | ||||||||
| #' is_expression(q3) | ||||||||
| #' is_call(q3) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' # Atomic expressions are the terminating nodes of a call tree: | ||||||||
| #' # NULL or a scalar atomic vector: | ||||||||
| #' is_syntactic_literal("string") | ||||||||
| #' is_syntactic_literal(NULL) | ||||||||
| #' | ||||||||
| #' is_syntactic_literal(letters) | ||||||||
| #' is_syntactic_literal(quote(call())) | ||||||||
| #' | ||||||||
| #' # Parsable literals have the property of being self-quoting: | ||||||||
| #' identical("foo", quote("foo")) | ||||||||
| #' identical(1L, quote(1L)) | ||||||||
| #' identical(NULL, quote(NULL)) | ||||||||
| #' | ||||||||
| #' # Like any literals, they can be evaluated within the empty | ||||||||
| #' # environment: | ||||||||
| #' eval_bare(quote(1L), empty_env()) | ||||||||
| #' | ||||||||
| #' # Whereas it would fail for symbolic expressions: | ||||||||
| #' # eval_bare(quote(c(1L, 2L)), empty_env()) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' # Pairlists are also language objects representing argument lists. | ||||||||
| #' # You will usually encounter them with extracted formals: | ||||||||
| #' fmls <- formals(is_expression) | ||||||||
| #' typeof(fmls) | ||||||||
| #' | ||||||||
| #' # Since they are mostly an internal data structure, is_expression() | ||||||||
| #' # returns FALSE for pairlists, so you will have to check explicitly | ||||||||
| #' # for them: | ||||||||
| #' is_expression(fmls) | ||||||||
| #' is_pairlist(fmls) | ||||||||
| is_expression <- function(x) { | ||||||||
| is_symbolic(x) || is_syntactic_literal(x) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname is_expression | ||||||||
| is_syntactic_literal <- function(x) { | ||||||||
| switch(typeof(x), | ||||||||
| NULL = { | ||||||||
| TRUE | ||||||||
| }, | ||||||||
| logical = , | ||||||||
| integer = , | ||||||||
| double = , | ||||||||
| character = { | ||||||||
| length(x) == 1 | ||||||||
| }, | ||||||||
| complex = { | ||||||||
| if (length(x) != 1) { | ||||||||
| return(FALSE) | ||||||||
| } | ||||||||
| is_na(x) || Re(x) == 0 | ||||||||
| }, | ||||||||
| FALSE | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname is_expression | ||||||||
| is_symbolic <- function(x) { | ||||||||
| typeof(x) %in% c("language", "symbol") | ||||||||
| } | ||||||||
| #' Turn an expression to a label | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' \Sexpr[results=rd, stage=render]{rlang:::lifecycle("questioning")} | ||||||||
| #' | ||||||||
| #' `expr_text()` turns the expression into a single string, which | ||||||||
| #' might be multi-line. `expr_name()` is suitable for formatting | ||||||||
| #' names. It works best with symbols and scalar types, but also | ||||||||
| #' accepts calls. `expr_label()` formats the expression nicely for use | ||||||||
| #' in messages. | ||||||||
| #' | ||||||||
| #' @param expr An expression to labellise. | ||||||||
| #' | ||||||||
| #' @section Life cycle: | ||||||||
| #' | ||||||||
| #' These functions are in the questioning stage because they are | ||||||||
| #' redundant with the `quo_` variants and do not handle quosures. | ||||||||
| #' | ||||||||
| #' @examples | ||||||||
| #' # To labellise a function argument, first capture it with | ||||||||
| #' # substitute(): | ||||||||
| #' fn <- function(x) expr_label(substitute(x)) | ||||||||
| #' fn(x:y) | ||||||||
| #' | ||||||||
| #' # Strings are encoded | ||||||||
| #' expr_label("a\nb") | ||||||||
| #' | ||||||||
| #' # Names and expressions are quoted with `` | ||||||||
| #' expr_label(quote(x)) | ||||||||
| #' expr_label(quote(a + b + c)) | ||||||||
| #' | ||||||||
| #' # Long expressions are collapsed | ||||||||
| #' expr_label(quote(foo({ | ||||||||
| #' 1 + 2 | ||||||||
| #' print(x) | ||||||||
| #' }))) | ||||||||
| #' @export | ||||||||
| expr_label <- function(expr) { | ||||||||
| if (is.character(expr)) { | ||||||||
| encodeString(expr, quote = '"') | ||||||||
| } else if (is.atomic(expr)) { | ||||||||
| format(expr) | ||||||||
| } else if (is.name(expr)) { | ||||||||
| paste0("`", as.character(expr), "`") | ||||||||
| } else { | ||||||||
| chr <- deparse_one(expr) | ||||||||
| paste0("`", chr, "`") | ||||||||
| } | ||||||||
| } | ||||||||
| #' @rdname expr_label | ||||||||
| #' @export | ||||||||
| expr_name <- function(expr) { | ||||||||
| if (is_null(expr)) { | ||||||||
| return("NULL") | ||||||||
| } | ||||||||
| if (is_symbol(expr)) { | ||||||||
| return(as_string(expr)) | ||||||||
| } | ||||||||
| if (is_call(expr)) { | ||||||||
| if (is_data_pronoun(expr)) { | ||||||||
| name <- data_pronoun_name(expr) %||% "<unknown>" | ||||||||
| } else { | ||||||||
| name <- deparse_one(expr) | ||||||||
| name <- gsub("\n.*$", "...", name) | ||||||||
| } | ||||||||
| return(name) | ||||||||
| } | ||||||||
| # So 1L is translated to "1" and not "1L" | ||||||||
| if (is_scalar_atomic(expr)) { | ||||||||
| return(as.character(expr)) | ||||||||
| } | ||||||||
| if (length(expr) == 1) { | ||||||||
| name <- expr_text(expr) | ||||||||
| name <- gsub("\n.*$", "...", name) | ||||||||
| return(name) | ||||||||
| } | ||||||||
| abort("`expr` must quote a symbol, scalar, or call") | ||||||||
| } | ||||||||
| #' @rdname expr_label | ||||||||
| #' @export | ||||||||
| #' @param width Width of each line. | ||||||||
| #' @param nlines Maximum number of lines to extract. | ||||||||
| expr_text <- function(expr, width = 60L, nlines = Inf) { | ||||||||
| if (is_symbol(expr)) { | ||||||||
| return(sym_text(expr)) | ||||||||
| } | ||||||||
| str <- deparse(expr, width.cutoff = width, backtick = TRUE) | ||||||||
| if (length(str) > nlines) { | ||||||||
| str <- c(str[seq_len(nlines - 1)], "...") | ||||||||
| } | ||||||||
| paste0(str, collapse = "\n") | ||||||||
| } | ||||||||
| sym_text <- function(sym) { | ||||||||
| # Use as_string() to translate unicode tags | ||||||||
| text <- as_string(sym) | ||||||||
| if (needs_backticks(text)) { | ||||||||
| text <- sprintf("`%s`", text) | ||||||||
| } | ||||||||
| text | ||||||||
| } | ||||||||
| deparse_one <- function(expr) { | ||||||||
| str <- deparse(expr, 60L) | ||||||||
| if (length(str) > 1) { | ||||||||
| if (is_call(expr, function_sym)) { | ||||||||
| expr[[3]] <- quote(...) | ||||||||
| str <- deparse(expr, 60L) | ||||||||
| } else if (is_call(expr, brace_sym)) { | ||||||||
| str <- "{ ... }" | ||||||||
| } else if (is_call(expr)) { | ||||||||
| str <- deparse(call2(expr[[1]], quote(...)), 60L) | ||||||||
| } | ||||||||
| str <- paste(str, collapse = "\n") | ||||||||
| } | ||||||||
| str | ||||||||
| } | ||||||||
| #' Set and get an expression | ||||||||
| #' | ||||||||
| #' These helpers are useful to make your function work generically | ||||||||
| #' with quosures and raw expressions. First call `get_expr()` to | ||||||||
| #' extract an expression. Once you're done processing the expression, | ||||||||
| #' call `set_expr()` on the original object to update the expression. | ||||||||
| #' You can return the result of `set_expr()`, either a formula or an | ||||||||
| #' expression depending on the input type. Note that `set_expr()` does | ||||||||
| #' not change its input, it creates a new object. | ||||||||
| #' | ||||||||
| #' @param x An expression, closure, or one-sided formula. In addition, | ||||||||
| #' `set_expr()` accept frames. | ||||||||
| #' @param value An updated expression. | ||||||||
| #' @param default A default expression to return when `x` is not an | ||||||||
| #' expression wrapper. Defaults to `x` itself. | ||||||||
| #' @return The updated original input for `set_expr()`. A raw | ||||||||
| #' expression for `get_expr()`. | ||||||||
| #' @seealso [quo_get_expr()] and [quo_set_expr()] for versions of | ||||||||
| #' [get_expr()] and [set_expr()] that only work on quosures. | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' f <- ~foo(bar) | ||||||||
| #' e <- quote(foo(bar)) | ||||||||
| #' frame <- identity(identity(ctxt_frame())) | ||||||||
| #' | ||||||||
| #' get_expr(f) | ||||||||
| #' get_expr(e) | ||||||||
| #' get_expr(frame) | ||||||||
| #' | ||||||||
| #' set_expr(f, quote(baz)) | ||||||||
| #' set_expr(e, quote(baz)) | ||||||||
| set_expr <- function(x, value) { | ||||||||
| if (is_quosure(x)) { | ||||||||
| x <- quo_set_expr(x, value) | ||||||||
| } else if (is_formula(x)) { | ||||||||
| f_rhs(x) <- value | ||||||||
| } else if (is_closure(x)) { | ||||||||
| body(x) <- value | ||||||||
| } else { | ||||||||
| x <- value | ||||||||
| } | ||||||||
| x | ||||||||
| } | ||||||||
| #' @rdname set_expr | ||||||||
| #' @export | ||||||||
| get_expr <- function(x, default = x) { | ||||||||
| .Call(rlang_get_expression, x, default) | ||||||||
| } | ||||||||
| expr_type_of <- function(x) { | ||||||||
| if (missing(x)) { | ||||||||
| return("missing") | ||||||||
| } | ||||||||
| type <- typeof(x) | ||||||||
| if (type %in% c("symbol", "language", "pairlist", "NULL")) { | ||||||||
| type | ||||||||
| } else { | ||||||||
| "literal" | ||||||||
| } | ||||||||
| } | ||||||||
| switch_expr <- function(.x, ...) { | ||||||||
| switch(expr_type_of(.x), ...) | ||||||||
| } | ||||||||
| #' Print an expression | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' `expr_print()`, powered by `expr_deparse()`, is an alternative | ||||||||
| #' printer for R expressions with a few improvements over the base R | ||||||||
| #' printer. | ||||||||
| #' | ||||||||
| #' * It colourises [quosures][nse-defuse] according to their environment. | ||||||||
| #' Quosures from the global environment are printed normally while | ||||||||
| #' quosures from local environments are printed in unique colour (or | ||||||||
| #' in italic when all colours are taken). | ||||||||
| #' | ||||||||
| #' * It wraps inlined objects in angular brackets. For instance, an | ||||||||
| #' integer vector unquoted in a function call (e.g. | ||||||||
| #' `expr(foo(!!(1:3)))`) is printed like this: `foo(<int: 1L, 2L, | ||||||||
| #' 3L>)` while by default R prints the code to create that vector: | ||||||||
| #' `foo(1:3)` which is ambiguous. | ||||||||
| #' | ||||||||
| #' * It respects the width boundary (from the global option `width`) | ||||||||
| #' in more cases. | ||||||||
| #' | ||||||||
| #' @param x An object or expression to print. | ||||||||
| #' @param width The width of the deparsed or printed expression. | ||||||||
| #' Defaults to the global option `width`. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # It supports any object. Non-symbolic objects are always printed | ||||||||
| #' # within angular brackets: | ||||||||
| #' expr_print(1:3) | ||||||||
| #' expr_print(function() NULL) | ||||||||
| #' | ||||||||
| #' # Contrast this to how the code to create these objects is printed: | ||||||||
| #' expr_print(quote(1:3)) | ||||||||
| #' expr_print(quote(function() NULL)) | ||||||||
| #' | ||||||||
| #' # The main cause of non-symbolic objects in expressions is | ||||||||
| #' # quasiquotation: | ||||||||
| #' expr_print(expr(foo(!!(1:3)))) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' # Quosures from the global environment are printed normally: | ||||||||
| #' expr_print(quo(foo)) | ||||||||
| #' expr_print(quo(foo(!!quo(bar)))) | ||||||||
| #' | ||||||||
| #' # Quosures from local environments are colourised according to | ||||||||
| #' # their environments (if you have crayon installed): | ||||||||
| #' local_quo <- local(quo(foo)) | ||||||||
| #' expr_print(local_quo) | ||||||||
| #' | ||||||||
| #' wrapper_quo <- local(quo(bar(!!local_quo, baz))) | ||||||||
| #' expr_print(wrapper_quo) | ||||||||
| expr_print <- function(x, width = peek_option("width")) { | ||||||||
| cat_line(expr_deparse(x, width = width)) | ||||||||
| } | ||||||||
| #' @rdname expr_print | ||||||||
| #' @export | ||||||||
| expr_deparse <- function(x, width = peek_option("width")) { | ||||||||
| deparser <- new_quo_deparser(width = width) | ||||||||
| quo_deparse(x, deparser) | ||||||||
| } | ||||||||
| rlang/R/quo.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Quosure getters, setters and testers | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' A quosure is a type of [quoted expression][nse-defuse] that includes | ||||||||
| #' a reference to the context where it was created. A quosure is thus | ||||||||
| #' guaranteed to evaluate in its original environment and can refer to | ||||||||
| #' local objects. | ||||||||
| #' | ||||||||
| #' You can access the quosure components (its expression and its | ||||||||
| #' environment) with: | ||||||||
| #' | ||||||||
| #' * [get_expr()] and [get_env()]. These getters also support other | ||||||||
| #' kinds of objects such as formulas. | ||||||||
| #' | ||||||||
| #' * `quo_get_expr()` and `quo_get_env()`. These getters only work | ||||||||
| #' with quosures and throw an error with other types of input. | ||||||||
| #' | ||||||||
| #' Test if an object is a quosure with `is_quosure()`. If you know an | ||||||||
| #' object is a quosure, use the `quo_` prefixed predicates to check | ||||||||
| #' its contents, `quo_is_missing()`, `quo_is_symbol()`, etc. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @section Quosured constants: | ||||||||
| #' | ||||||||
| #' A quosure usually does not carry environments for [constant | ||||||||
| #' objects][is_syntactic_literal] like strings or numbers. [quo()] and | ||||||||
| #' [enquo()] only capture an environment for [symbolic | ||||||||
| #' expressions][is_symbolic]. For instance, all of these return the | ||||||||
| #' [empty environment][empty_env]: | ||||||||
| #' | ||||||||
| #' ``` | ||||||||
| #' quo_get_env(quo("constant")) | ||||||||
| #' quo_get_env(quo(100)) | ||||||||
| #' quo_get_env(quo(NA)) | ||||||||
| #' ``` | ||||||||
| #' | ||||||||
| #' On the other hand, quosures capture the environment of symbolic | ||||||||
| #' expressions, i.e. expressions whose meaning depends on the | ||||||||
| #' environment in which they are evaluated and what objects are | ||||||||
| #' defined there: | ||||||||
| #' | ||||||||
| #' ``` | ||||||||
| #' quo_get_env(quo(some_object)) | ||||||||
| #' quo_get_env(quo(some_function())) | ||||||||
| #' ``` | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @section Empty quosures: | ||||||||
| #' | ||||||||
| #' When missing arguments are captured as quosures, either through | ||||||||
| #' [enquo()] or [quos()], they are returned as an empty quosure. These | ||||||||
| #' quosures contain the [missing argument][missing_arg] and typically | ||||||||
| #' have the [empty environment][empty_env] as enclosure. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @section Life cycle: | ||||||||
| #' | ||||||||
| #' - `is_quosure()` is stable. | ||||||||
| #' | ||||||||
| #' - `quo_get_expr()` and `quo_get_env()` are stable. | ||||||||
| #' | ||||||||
| #' @name quosure | ||||||||
| #' @seealso [quo()] for creating quosures by quotation; [as_quosure()] | ||||||||
| #' and [new_quosure()] for constructing quosures manually. | ||||||||
| #' @examples | ||||||||
| #' quo <- quo(my_quosure) | ||||||||
| #' quo | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' # Access and set the components of a quosure: | ||||||||
| #' quo_get_expr(quo) | ||||||||
| #' quo_get_env(quo) | ||||||||
| #' | ||||||||
| #' quo <- quo_set_expr(quo, quote(baz)) | ||||||||
| #' quo <- quo_set_env(quo, empty_env()) | ||||||||
| #' quo | ||||||||
| #' | ||||||||
| #' # Test wether an object is a quosure: | ||||||||
| #' is_quosure(quo) | ||||||||
| #' | ||||||||
| #' # If it is a quosure, you can use the specialised type predicates | ||||||||
| #' # to check what is inside it: | ||||||||
| #' quo_is_symbol(quo) | ||||||||
| #' quo_is_call(quo) | ||||||||
| #' quo_is_null(quo) | ||||||||
| #' | ||||||||
| #' # quo_is_missing() checks for a special kind of quosure, the one | ||||||||
| #' # that contains the missing argument: | ||||||||
| #' quo() | ||||||||
| #' quo_is_missing(quo()) | ||||||||
| #' | ||||||||
| #' fn <- function(arg) enquo(arg) | ||||||||
| #' fn() | ||||||||
| #' quo_is_missing(fn()) | ||||||||
| NULL | ||||||||
| #' @rdname quosure | ||||||||
| #' @param x An object to test. | ||||||||
| #' @export | ||||||||
| is_quosure <- function(x) { | ||||||||
| inherits(x, "quosure") | ||||||||
| } | ||||||||
| #' @rdname quosure | ||||||||
| #' @param quo A quosure to test. | ||||||||
| #' @export | ||||||||
| quo_is_missing <- function(quo) { | ||||||||
| .Call(rlang_quo_is_missing, quo) | ||||||||
| } | ||||||||
| #' @rdname quosure | ||||||||
| #' @param name The name of the symbol or function call. If `NULL` the | ||||||||
| #' name is not tested. | ||||||||
| #' @export | ||||||||
| quo_is_symbol <- function(quo, name = NULL) { | ||||||||
| is_symbol(quo_get_expr(quo), name = name) | ||||||||
| } | ||||||||
| #' @rdname quosure | ||||||||
| #' @inheritParams is_call | ||||||||
| #' @export | ||||||||
| quo_is_call <- function(quo, name = NULL, n = NULL, ns = NULL) { | ||||||||
| is_call(quo_get_expr(quo), name = name, n = n, ns = ns) | ||||||||
| } | ||||||||
| #' @rdname quosure | ||||||||
| #' @export | ||||||||
| quo_is_symbolic <- function(quo) { | ||||||||
| .Call(rlang_quo_is_symbolic, quo) | ||||||||
| } | ||||||||
| #' @rdname quosure | ||||||||
| #' @export | ||||||||
| quo_is_null <- function(quo) { | ||||||||
| .Call(rlang_quo_is_null, quo) | ||||||||
| } | ||||||||
| #' @rdname quosure | ||||||||
| #' @export | ||||||||
| quo_get_expr <- function(quo) { | ||||||||
| .Call(rlang_quo_get_expr, quo) | ||||||||
| } | ||||||||
| #' @rdname quosure | ||||||||
| #' @export | ||||||||
| quo_get_env <- function(quo) { | ||||||||
| .Call(rlang_quo_get_env, quo) | ||||||||
| } | ||||||||
| #' @rdname quosure | ||||||||
| #' @param expr A new expression for the quosure. | ||||||||
| #' @export | ||||||||
| quo_set_expr <- function(quo, expr) { | ||||||||
| .Call(rlang_quo_set_expr, quo, expr) | ||||||||
| } | ||||||||
| #' @rdname quosure | ||||||||
| #' @param env A new environment for the quosure. | ||||||||
| #' @export | ||||||||
| quo_set_env <- function(quo, env) { | ||||||||
| .Call(rlang_quo_set_env, quo, env) | ||||||||
| } | ||||||||
| #' Create a list of quosures | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' This small S3 class provides methods for `[` and `c()` and ensures | ||||||||
| #' the following invariants: | ||||||||
| #' | ||||||||
| #' * The list only contains quosures. | ||||||||
| #' * It is always named, possibly with a vector of empty strings. | ||||||||
| #' | ||||||||
| #' `new_quosures()` takes a list of quosures and adds the `quosures` | ||||||||
| #' class and a vector of empty names if needed. `as_quosures()` calls | ||||||||
| #' [as_quosure()] on all elements before creating the `quosures` | ||||||||
| #' object. | ||||||||
| #' | ||||||||
| #' @param x A list of quosures or objects to coerce to quosures. | ||||||||
| #' @param env The default environment for the new quosures. | ||||||||
| #' @param named Whether to name the list with [quos_auto_name()]. | ||||||||
| #' @export | ||||||||
| new_quosures <- function(x) { | ||||||||
| if (!is_list(x) || !every(x, is_quosure)) { | ||||||||
| abort("Expected a list of quosures") | ||||||||
| } | ||||||||
| structure(x, | ||||||||
| class = c("quosures", "list"), | ||||||||
| names = names2(x) | ||||||||
| ) | ||||||||
| } | ||||||||
| #' @rdname new_quosures | ||||||||
| #' @export | ||||||||
| as_quosures <- function(x, env, named = FALSE) { | ||||||||
| x <- map(x, as_quosure, env = env) | ||||||||
| if (named) { | ||||||||
| x <- quos_auto_name(x) | ||||||||
| } | ||||||||
| new_quosures(x) | ||||||||
| } | ||||||||
| #' @rdname new_quosures | ||||||||
| #' @export | ||||||||
| is_quosures <- function(x) { | ||||||||
| inherits(x, "quosures") | ||||||||
| } | ||||||||
| #' @export | ||||||||
| `[.quosures` <- function(x, i) { | ||||||||
| structure(NextMethod(), class = c("quosures", "list")) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| c.quosures <- function(..., recursive = FALSE) { | ||||||||
| out <- NextMethod() | ||||||||
| if (every(out, is_quosure)) { | ||||||||
| new_quosures(out) | ||||||||
| } else { | ||||||||
| warn_deprecated(paste_line( | ||||||||
| "Quosure lists can't be concatenated with objects other than quosures as of rlang 0.3.0.", | ||||||||
| "Please call `as.list()` on the quosure list first." | ||||||||
| )) | ||||||||
| out | ||||||||
| } | ||||||||
| } | ||||||||
| #' @export | ||||||||
| print.quosures <- function(x, ...) { | ||||||||
| cat_line("<list_of<quosure>>\n") | ||||||||
| print(unclass(x), ...) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| as.list.quosures <- function(x, ...) { | ||||||||
| unclass(x) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| `[<-.quosures` <- function(x, i, value) { | ||||||||
| if (idx <- detect_index(value, negate(is_quosure))) { | ||||||||
| signal_quosure_assign(value[[idx]]) | ||||||||
| } | ||||||||
| NextMethod() | ||||||||
| } | ||||||||
| #' @export | ||||||||
| `[[<-.quosures` <- function(x, i, value) { | ||||||||
| if (!is_quosure(value) && !is_null(value)) { | ||||||||
| signal_quosure_assign(value) | ||||||||
| } | ||||||||
| NextMethod() | ||||||||
| } | ||||||||
| #' @export | ||||||||
| `$<-.quosures` <- function(x, name, value) { | ||||||||
| x[[name]] <- value | ||||||||
| x | ||||||||
| } | ||||||||
| signal_quosure_assign <- function(x) { | ||||||||
| warn_deprecated(paste_line( | ||||||||
| "Assigning non-quosure objects to quosure lists is deprecated as of rlang 0.3.0.", | ||||||||
| "Please coerce to a bare list beforehand with `as.list()`" | ||||||||
| )) | ||||||||
| } | ||||||||
| # Dynamically registered | ||||||||
| pillar_shaft.quosures <- function(x, ...) { | ||||||||
| labels <- map_chr(unname(x), as_label) | ||||||||
| structure(labels, width = 10L) | ||||||||
| } | ||||||||
| type_sum.quosures <- function(x) { | ||||||||
| "quos" | ||||||||
| } | ||||||||
| #' Coerce object to quosure | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' While `new_quosure()` wraps any R object (including expressions, | ||||||||
| #' formulas, or other quosures) into a quosure, `as_quosure()` | ||||||||
| #' converts formulas and quosures and does not double-wrap. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @section Life cycle: | ||||||||
| #' | ||||||||
| #' - `as_quosure()` now requires an explicit default environment for | ||||||||
| #' creating quosures from symbols and calls. | ||||||||
| #' | ||||||||
| #' - `as_quosureish()` is deprecated as of rlang 0.2.0. This function | ||||||||
| #' assumes that quosures are formulas which is currently true but | ||||||||
| #' might not be in the future. | ||||||||
| #' | ||||||||
| #' @param x An object to convert. Either an [expression][is_expression] or a | ||||||||
| #' formula. | ||||||||
| #' @param env The environment in which the expression should be | ||||||||
| #' evaluated. Only used for symbols and calls. This should typically | ||||||||
| #' be the environment in which the expression was created. | ||||||||
| #' @seealso [quo()], [is_quosure()] | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # as_quosure() converts expressions or any R object to a validly | ||||||||
| #' # scoped quosure: | ||||||||
| #' env <- env(var = "thing") | ||||||||
| #' as_quosure(quote(var), env) | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' # The environment is ignored for formulas: | ||||||||
| #' as_quosure(~foo, env) | ||||||||
| #' as_quosure(~foo) | ||||||||
| #' | ||||||||
| #' # However you must supply it for symbols and calls: | ||||||||
| #' try(as_quosure(quote(var))) | ||||||||
| as_quosure <- function(x, env = NULL) { | ||||||||
| if (is_quosure(x)) { | ||||||||
| return(x) | ||||||||
| } | ||||||||
| if (is_bare_formula(x)) { | ||||||||
| env <- f_env(x) | ||||||||
| if (is_null(env)) { | ||||||||
| abort(paste_line( | ||||||||
| "The formula does not have an environment.", | ||||||||
| "This is a quoted formula that was never evaluated." | ||||||||
| )) | ||||||||
| } | ||||||||
| return(new_quosure(f_rhs(x), env)) | ||||||||
| } | ||||||||
| if (is_symbolic(x)) { | ||||||||
| if (is_null(env)) { | ||||||||
| warn_deprecated(paste_line( | ||||||||
| "`as_quosure()` requires an explicit environment as of rlang 0.3.0.", | ||||||||
| "Please supply `env`." | ||||||||
| )) | ||||||||
| env <- caller_env() | ||||||||
| } | ||||||||
| return(new_quosure(x, env)) | ||||||||
| } | ||||||||
| new_quosure(x, empty_env()) | ||||||||
| } | ||||||||
| #' @rdname as_quosure | ||||||||
| #' @param expr The expression wrapped by the quosure. | ||||||||
| #' @export | ||||||||
| new_quosure <- function(expr, env = caller_env()) { | ||||||||
| .Call(rlang_new_quosure, expr, env) | ||||||||
| } | ||||||||
| #' Squash a quosure | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' `quo_squash()` flattens all nested quosures within an expression. | ||||||||
| #' For example it transforms `^foo(^bar(), ^baz)` to the bare | ||||||||
| #' expression `foo(bar(), baz)`. | ||||||||
| #' | ||||||||
| #' This operation is safe if the squashed quosure is used for | ||||||||
| #' labelling or printing (see [quo_label()] or [quo_name()]). However | ||||||||
| #' if the squashed quosure is evaluated, all expressions of the | ||||||||
| #' flattened quosures are resolved in a single environment. This is a | ||||||||
| #' source of bugs so it is good practice to set `warn` to `TRUE` to | ||||||||
| #' let the user know about the lossy squashing. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @section Life cycle: | ||||||||
| #' | ||||||||
| #' This function replaces `quo_expr()` which was deprecated in | ||||||||
| #' rlang 0.2.0. `quo_expr()` was a misnomer because it implied that it | ||||||||
| #' was a mere expression acccessor for quosures whereas it was really | ||||||||
| #' a lossy operation that squashed all nested quosures. | ||||||||
| #' | ||||||||
| #' | ||||||||
| #' @param quo A quosure or expression. | ||||||||
| #' @param warn Whether to warn if the quosure contains other quosures | ||||||||
| #' (those will be collapsed). This is useful when you use | ||||||||
| #' `quo_squash()` in order to make a non-tidyeval API compatible | ||||||||
| #' with quosures. In that case, getting rid of the nested quosures | ||||||||
| #' is likely to cause subtle bugs and it is good practice to warn | ||||||||
| #' the user about it. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # Quosures can contain nested quosures: | ||||||||
| #' quo <- quo(wrapper(!!quo(wrappee))) | ||||||||
| #' quo | ||||||||
| #' | ||||||||
| #' # quo_squash() flattens all the quosures and returns a simple expression: | ||||||||
| #' quo_squash(quo) | ||||||||
| quo_squash <- function(quo, warn = FALSE) { | ||||||||
| # Never warn when unwrapping outer quosure | ||||||||
| if (is_quosure(quo)) { | ||||||||
| quo <- quo_get_expr(quo) | ||||||||
| } | ||||||||
| if (is_missing(quo)) { | ||||||||
| missing_arg() | ||||||||
| } else { | ||||||||
| quo_squash_impl(duplicate(quo), warn = warn) | ||||||||
| } | ||||||||
| } | ||||||||
| #' Format quosures for printing or labelling | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' \Sexpr[results=rd, stage=render]{rlang:::lifecycle("questioning")} | ||||||||
| #' | ||||||||
| #' **Note:** You should now use [as_label()] or [as_name()] instead | ||||||||
| #' of `quo_name()`. See life cycle section below. | ||||||||
| #' | ||||||||
| #' These functions take an arbitrary R object, typically an | ||||||||
| #' [expression][is_expression], and represent it as a string. | ||||||||
| #' | ||||||||
| #' * `quo_name()` returns an abbreviated representation of the object | ||||||||
| #' as a single line string. It is suitable for default names. | ||||||||
| #' | ||||||||
| #' * `quo_text()` returns a multiline string. For instance block | ||||||||
| #' expressions like `{ foo; bar }` are represented on 4 lines (one | ||||||||
| #' for each symbol, and the curly braces on their own lines). | ||||||||
| #' | ||||||||
| #' These deparsers are only suitable for creating default names or | ||||||||
| #' printing output at the console. The behaviour of your functions | ||||||||
| #' should not depend on deparsed objects. If you are looking for a way | ||||||||
| #' of transforming symbols to strings, use [as_string()] instead of | ||||||||
| #' `quo_name()`. Unlike deparsing, the transformation between symbols | ||||||||
| #' and strings is non-lossy and well defined. | ||||||||
| #' | ||||||||
| #' @inheritParams quo_squash | ||||||||
| #' @inheritParams expr_label | ||||||||
| #' | ||||||||
| #' @section Life cycle: | ||||||||
| #' | ||||||||
| #' These functions are in the questioning life cycle stage. | ||||||||
| #' | ||||||||
| #' * [as_label()] and [as_name()] should be used instead of | ||||||||
| #' `quo_name()`. `as_label()` transforms any R object to a string | ||||||||
| #' but should only be used to create a default name. Labelisation is | ||||||||
| #' not a well defined operation and no assumption should be made | ||||||||
| #' about the label. On the other hand, `as_name()` only works with | ||||||||
| #' (possibly quosured) symbols, but is a well defined and | ||||||||
| #' deterministic operation. | ||||||||
| #' | ||||||||
| #' * We don't have a good replacement for `quo_text()` yet. See | ||||||||
| #' <https://github.com/r-lib/rlang/issues/636> to follow discussions | ||||||||
| #' about a new deparsing API. | ||||||||
| #' | ||||||||
| #' @seealso [expr_label()], [f_label()] | ||||||||
| #' @examples | ||||||||
| #' # Quosures can contain nested quosures: | ||||||||
| #' quo <- quo(foo(!! quo(bar))) | ||||||||
| #' quo | ||||||||
| #' | ||||||||
| #' # quo_squash() unwraps all quosures and returns a raw expression: | ||||||||
| #' quo_squash(quo) | ||||||||
| #' | ||||||||
| #' # This is used by quo_text() and quo_label(): | ||||||||
| #' quo_text(quo) | ||||||||
| #' | ||||||||
| #' # Compare to the unwrapped expression: | ||||||||
| #' expr_text(quo) | ||||||||
| #' | ||||||||
| #' # quo_name() is helpful when you need really short labels: | ||||||||
| #' quo_name(quo(sym)) | ||||||||
| #' quo_name(quo(!! sym)) | ||||||||
| #' @export | ||||||||
| quo_label <- function(quo) { | ||||||||
| expr_label(quo_squash(quo)) | ||||||||
| } | ||||||||
| #' @rdname quo_label | ||||||||
| #' @export | ||||||||
| quo_text <- function(quo, width = 60L, nlines = Inf) { | ||||||||
| expr_text(quo_squash(quo), width = width, nlines = nlines) | ||||||||
| } | ||||||||
| #' @rdname quo_label | ||||||||
| #' @export | ||||||||
| quo_name <- function(quo) { | ||||||||
| expr_name(quo_squash(quo)) | ||||||||
| } | ||||||||
| quo_squash_impl <- function(x, parent = NULL, warn = FALSE) { | ||||||||
| switch_expr(x, | ||||||||
| language = { | ||||||||
| if (is_quosure(x)) { | ||||||||
| if (!is_false(warn)) { | ||||||||
| if (is_string(warn)) { | ||||||||
| msg <- warn | ||||||||
| } else { | ||||||||
| msg <- "Collapsing inner quosure" | ||||||||
| } | ||||||||
| warn(msg) | ||||||||
| warn <- FALSE | ||||||||
| } | ||||||||
| while (is_quosure(x)) { | ||||||||
| x <- quo_get_expr(x) | ||||||||
| } | ||||||||
| if (!is_null(parent)) { | ||||||||
| node_poke_car(parent, x) | ||||||||
| } | ||||||||
| quo_squash_impl(x, parent, warn = warn) | ||||||||
| } else { | ||||||||
| quo_squash_impl(node_cdr(x), warn = warn) | ||||||||
| } | ||||||||
| }, | ||||||||
| pairlist = { | ||||||||
| while (!is_null(x)) { | ||||||||
| quo_squash_impl(node_car(x), x, warn = warn) | ||||||||
| x <- node_cdr(x) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| x | ||||||||
| } | ||||||||
| #' @export | ||||||||
| print.quosure <- function(x, ...) { | ||||||||
| cat_line(.trailing = FALSE, | ||||||||
| bold("<quosure>"), | ||||||||
| "expr: " | ||||||||
| ) | ||||||||
| quo_print(x) | ||||||||
| cat_line(.trailing = FALSE, | ||||||||
| "env: " | ||||||||
| ) | ||||||||
| env <- quo_get_env(x) | ||||||||
| quo_env_print(env) | ||||||||
| invisible(x) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| str.quosure <- function(object, ...) { | ||||||||
| str(unclass(object), ...) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| as.character.quosure <- function(x, ...) { | ||||||||
| warn_deprecated(paste_line( | ||||||||
| "Using `as.character()` on a quosure is deprecated as of rlang 0.3.0.", | ||||||||
| "Please use `as_label()` or `as_name()` instead." | ||||||||
| )) | ||||||||
| NextMethod() | ||||||||
| } | ||||||||
| #' @export | ||||||||
| `[.quosure` <- function(x, i, ...) { | ||||||||
| signal_soft_deprecated(c( | ||||||||
| "Subsetting quosures with `[` is deprecated as of rlang 0.4.0", | ||||||||
| "Please use `quo_get_expr()` instead." | ||||||||
| )) | ||||||||
| NextMethod() | ||||||||
| } | ||||||||
| #' @export | ||||||||
| `[[.quosure` <- function(x, i, ...) { | ||||||||
| signal_soft_deprecated(c( | ||||||||
| "Subsetting quosures with `[[` is deprecated as of rlang 0.4.0", | ||||||||
| "Please use `quo_get_expr()` instead." | ||||||||
| )) | ||||||||
| NextMethod() | ||||||||
| } | ||||||||
| # Create a circular list of colours. This infloops if printed in the REPL! | ||||||||
| new_quo_palette <- function() { | ||||||||
| last_node <- new_node(open_cyan, NULL) | ||||||||
| palette <- new_node(open_blue, new_node(open_green, new_node(open_magenta, last_node))) | ||||||||
| node_poke_cdr(last_node, palette) | ||||||||
| # First node has no colour | ||||||||
| new_node(close_colour, palette) | ||||||||
| } | ||||||||
| # Reproduces output of printed calls | ||||||||
| base_deparse <- function(x) { | ||||||||
| deparse(x, control = "keepInteger") | ||||||||
| } | ||||||||
| quo_deparse <- function(x, lines = new_quo_deparser()) { | ||||||||
| if (!is_quosure(x)) { | ||||||||
| return(sexp_deparse(x, lines = lines)) | ||||||||
| } | ||||||||
| env <- quo_get_env(x) | ||||||||
| lines$quo_open_colour(env) | ||||||||
| lines$push("^") | ||||||||
| lines$make_next_sticky() | ||||||||
| sexp_deparse(quo_get_expr(x), lines) | ||||||||
| lines$quo_reset_colour() | ||||||||
| lines$get_lines() | ||||||||
| } | ||||||||
| new_quo_deparser <- function(width = peek_option("width"), | ||||||||
| crayon = has_crayon()) { | ||||||||
| lines <- new_lines(width = width, deparser = quo_deparse) | ||||||||
| child_r6lite(lines, | ||||||||
| has_colour = crayon, | ||||||||
| quo_envs = list(), | ||||||||
| quo_history = pairlist(), | ||||||||
| quo_colours = list( | ||||||||
| open_blue, | ||||||||
| open_green, | ||||||||
| open_magenta, | ||||||||
| open_cyan, | ||||||||
| open_yellow | ||||||||
| ), | ||||||||
| quo_was_too_many = FALSE, | ||||||||
| quo_push_opener = function(self, opener) { | ||||||||
| self$quo_history <- new_node(opener, self$quo_history) | ||||||||
| self$push_sticky(opener()) | ||||||||
| self | ||||||||
| }, | ||||||||
| quo_open_colour = function(self, env) { | ||||||||
| if (self$has_colour) { | ||||||||
| if (is_reference(env, global_env()) || is_reference(env, empty_env())) { | ||||||||
| self$quo_push_opener(close_colour) | ||||||||
| return(NULL) | ||||||||
| } | ||||||||
| n_known_envs <- length(self$quo_envs) | ||||||||
| idx <- detect_index(self$quo_envs, identical, env) | ||||||||
| if (idx) { | ||||||||
| opener <- self$quo_colours[[idx]] | ||||||||
| } else if (n_known_envs < length(self$quo_colours)) { | ||||||||
| self$quo_envs <- c(self$quo_envs, list(env)) | ||||||||
| idx <- n_known_envs + 1L | ||||||||
| opener <- self$quo_colours[[idx]] | ||||||||
| } else { | ||||||||
| opener <- function() paste0(close_colour(), open_blurred_italic()) | ||||||||
| self$quo_was_too_many <- TRUE | ||||||||
| } | ||||||||
| self$quo_push_opener(opener) | ||||||||
| } | ||||||||
| }, | ||||||||
| quo_reset_colour = function(self) { | ||||||||
| if (self$has_colour) { | ||||||||
| if (self$quo_was_too_many) { | ||||||||
| self$push_sticky(close_blurred_italic()) | ||||||||
| } | ||||||||
| self$quo_history <- node_cdr(self$quo_history) | ||||||||
| reset <- node_car(self$quo_history) %||% close_colour | ||||||||
| self$push_sticky(reset()) | ||||||||
| } | ||||||||
| } | ||||||||
| ) | ||||||||
| } | ||||||||
| quo_print <- function(quo) { | ||||||||
| # Take into account the first 8-character wide columns | ||||||||
| width <- peek_option("width") - 10L | ||||||||
| deparser <- new_quo_deparser(width = width) | ||||||||
| lines <- quo_deparse(quo, deparser) | ||||||||
| n <- length(lines) | ||||||||
| lines[seq2(2, n)] <- paste0(" ", lines[seq2(2, n)]) | ||||||||
| cat(paste0(lines, "\n")) | ||||||||
| } | ||||||||
| quo_env_print <- function(env) { | ||||||||
| nm <- env_label(env) | ||||||||
| if (!is_reference(env, global_env()) && !is_reference(env, empty_env())) { | ||||||||
| nm <- blue(nm) | ||||||||
| } | ||||||||
| cat_line(nm) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| Ops.quosure <- function(e1, e2) { | ||||||||
| if (identical(.Generic, "!")) { | ||||||||
| abort(paste_line( | ||||||||
| "Quosures can only be unquoted within a quasiquotation context.", | ||||||||
| "", | ||||||||
| " # Bad:", | ||||||||
| " list(!!myquosure)", | ||||||||
| "", | ||||||||
| " # Good:", | ||||||||
| " dplyr::mutate(data, !!myquosure)" | ||||||||
| )) | ||||||||
| } | ||||||||
| if (missing(e2)) { | ||||||||
| bad <- sprintf(" %s%s", .Generic, "myquosure") | ||||||||
| good <- sprintf(" %s!!%s", .Generic, "myquosure") | ||||||||
| } else if (is_quosure(e1) && is_quosure(e2)) { | ||||||||
| bad <- sprintf(" myquosure1 %s myquosure2", .Generic) | ||||||||
| good <- sprintf(" !!myquosure1 %s !!myquosure2", .Generic) | ||||||||
| } else if (is_quosure(e1)) { | ||||||||
| bad <- sprintf(" myquosure %s rhs", .Generic) | ||||||||
| good <- sprintf(" !!myquosure %s rhs", .Generic) | ||||||||
| } else { | ||||||||
| bad <- sprintf(" lhs %s myquosure", .Generic) | ||||||||
| good <- sprintf(" lhs %s !!myquosure", .Generic) | ||||||||
| } | ||||||||
| abort(paste_line( | ||||||||
| "Base operators are not defined for quosures.", | ||||||||
| "Do you need to unquote the quosure?", | ||||||||
| "", | ||||||||
| " # Bad:", | ||||||||
| bad, | ||||||||
| "", | ||||||||
| " # Good:", | ||||||||
| good, | ||||||||
| )) | ||||||||
| } | ||||||||
| abort_quosure_op <- function(group, op) { | ||||||||
| abort(paste_line( | ||||||||
| sprintf("%s operations are not defined for quosures.", group), | ||||||||
| "Do you need to unquote the quosure?", | ||||||||
| "", | ||||||||
| " # Bad:", | ||||||||
| sprintf(" %s(myquosure)", op), | ||||||||
| "", | ||||||||
| " # Good:", | ||||||||
| sprintf(" %s(!!myquosure)", op), | ||||||||
| )) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| Math.quosure <- function(x, ...) { | ||||||||
| abort_quosure_op("Math", .Generic) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| Summary.quosure <- function(x, ...) { | ||||||||
| abort_quosure_op("Summary", .Generic) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| mean.quosure <- function(x, na.rm = TRUE, ...) { | ||||||||
| abort_quosure_op("Summary", "mean") | ||||||||
| } | ||||||||
| #' @importFrom stats median | ||||||||
| #' @export | ||||||||
| median.quosure <- function(x, na.rm = TRUE, ...) { | ||||||||
| abort_quosure_op("Summary", "median") | ||||||||
| } | ||||||||
| #' @importFrom stats quantile | ||||||||
| #' @export | ||||||||
| quantile.quosure <- function(x, na.rm = TRUE, ...) { | ||||||||
| abort_quosure_op("Summary", "quantile") | ||||||||
| } | ||||||||
| rlang/R/types.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Type predicates | ||||||||
| #' | ||||||||
| #' These type predicates aim to make type testing in R more | ||||||||
| #' consistent. They are wrappers around [base::typeof()], so operate | ||||||||
| #' at a level beneath S3/S4 etc. | ||||||||
| #' | ||||||||
| #' Compared to base R functions: | ||||||||
| #' | ||||||||
| #' * The predicates for vectors include the `n` argument for | ||||||||
| #' pattern-matching on the vector length. | ||||||||
| #' | ||||||||
| #' * Unlike `is.atomic()`, `is_atomic()` does not return `TRUE` for | ||||||||
| #' `NULL`. | ||||||||
| #' | ||||||||
| #' * Unlike `is.vector()`, `is_vector()` tests if an object is an | ||||||||
| #' atomic vector or a list. `is.vector` checks for the presence of | ||||||||
| #' attributes (other than name). | ||||||||
| #' | ||||||||
| #' @param x Object to be tested. | ||||||||
| #' @param n Expected length of a vector. | ||||||||
| #' @param finite Whether all values of the vector are finite. The | ||||||||
| #' non-finite values are `NA`, `Inf`, `-Inf` and `NaN`. Setting this | ||||||||
| #' to something other than `NULL` can be expensive because the whole | ||||||||
| #' vector needs to be traversed and checked. | ||||||||
| #' @seealso [bare-type-predicates] [scalar-type-predicates] | ||||||||
| #' @name type-predicates | ||||||||
| NULL | ||||||||
| #' @export | ||||||||
| #' @rdname type-predicates | ||||||||
| is_list <- function(x, n = NULL) { | ||||||||
| .Call(rlang_is_list, x, n) | ||||||||
| } | ||||||||
| parsable_atomic_types <- c("logical", "integer", "double", "complex", "character") | ||||||||
| atomic_types <- c(parsable_atomic_types, "raw") | ||||||||
| #' @export | ||||||||
| #' @rdname type-predicates | ||||||||
| is_atomic <- function(x, n = NULL) { | ||||||||
| .Call(rlang_is_atomic, x, n) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname type-predicates | ||||||||
| is_vector <- function(x, n = NULL) { | ||||||||
| .Call(rlang_is_vector, x, n) | ||||||||
| } | ||||||||
| # Mostly for unit testing | ||||||||
| is_finite <- function(x) { | ||||||||
| .Call(rlang_is_finite, x) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname type-predicates | ||||||||
| is_integer <- function(x, n = NULL) { | ||||||||
| .Call(rlang_is_integer, x, n) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname type-predicates | ||||||||
| is_double <- function(x, n = NULL, finite = NULL) { | ||||||||
| .Call(rlang_is_double, x, n, finite) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname type-predicates | ||||||||
| is_character <- function(x, n = NULL) { | ||||||||
| .Call(rlang_is_character, x, n) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname type-predicates | ||||||||
| is_logical <- function(x, n = NULL) { | ||||||||
| .Call(rlang_is_logical, x, n) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname type-predicates | ||||||||
| is_raw <- function(x, n = NULL) { | ||||||||
| .Call(rlang_is_raw, x, n) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname type-predicates | ||||||||
| is_bytes <- is_raw | ||||||||
| #' @export | ||||||||
| #' @usage is_null(x) | ||||||||
| #' @rdname type-predicates | ||||||||
| is_null <- is.null | ||||||||
| #' Scalar type predicates | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' These predicates check for a given type and whether the vector is | ||||||||
| #' "scalar", that is, of length 1. | ||||||||
| #' | ||||||||
| #' In addition to the length check, `is_string()` and `is_bool()` | ||||||||
| #' return `FALSE` if their input is missing. This is useful for | ||||||||
| #' type-checking arguments, when your function expects a single string | ||||||||
| #' or a single `TRUE` or `FALSE`. | ||||||||
| #' | ||||||||
| #' @param x object to be tested. | ||||||||
| #' @seealso [type-predicates], [bare-type-predicates] | ||||||||
| #' @name scalar-type-predicates | ||||||||
| NULL | ||||||||
| #' @export | ||||||||
| #' @rdname scalar-type-predicates | ||||||||
| is_scalar_list <- function(x) { | ||||||||
| .Call(rlang_is_list, x, 1L) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname scalar-type-predicates | ||||||||
| is_scalar_atomic <- function(x) { | ||||||||
| .Call(rlang_is_atomic, x, 1L) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname scalar-type-predicates | ||||||||
| is_scalar_vector <- function(x) { | ||||||||
| .Call(rlang_is_vector, x, 1L) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname scalar-type-predicates | ||||||||
| is_scalar_integer <- function(x) { | ||||||||
| .Call(rlang_is_integer, x, 1L) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname scalar-type-predicates | ||||||||
| is_scalar_double <- function(x) { | ||||||||
| .Call(rlang_is_double, x, 1L, NULL) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname scalar-type-predicates | ||||||||
| is_scalar_character <- function(x) { | ||||||||
| is_character(x, n = 1L) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname scalar-type-predicates | ||||||||
| is_scalar_logical <- function(x) { | ||||||||
| .Call(rlang_is_logical, x, 1L) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname scalar-type-predicates | ||||||||
| is_scalar_raw <- function(x) { | ||||||||
| .Call(rlang_is_raw, x, 1L) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @param string A string to compare to `x`. If a character vector, | ||||||||
| #' returns `TRUE` if at least one element is equal to `x`. | ||||||||
| #' @rdname scalar-type-predicates | ||||||||
| is_string <- function(x, string = NULL) { | ||||||||
| .Call(rlang_is_string, x, string) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname scalar-type-predicates | ||||||||
| is_scalar_bytes <- is_scalar_raw | ||||||||
| #' @export | ||||||||
| #' @rdname scalar-type-predicates | ||||||||
| is_bool <- function(x) { | ||||||||
| is_logical(x, n = 1) && !is.na(x) | ||||||||
| } | ||||||||
| #' Bare type predicates | ||||||||
| #' | ||||||||
| #' These predicates check for a given type but only return `TRUE` for | ||||||||
| #' bare R objects. Bare objects have no class attributes. For example, | ||||||||
| #' a data frame is a list, but not a bare list. | ||||||||
| #' | ||||||||
| #' * The predicates for vectors include the `n` argument for | ||||||||
| #' pattern-matching on the vector length. | ||||||||
| #' | ||||||||
| #' * Like [is_atomic()] and unlike base R `is.atomic()`, | ||||||||
| #' `is_bare_atomic()` does not return `TRUE` for `NULL`. | ||||||||
| #' | ||||||||
| #' * Unlike base R `is.numeric()`, `is_bare_double()` only returns | ||||||||
| #' `TRUE` for floating point numbers. | ||||||||
| #' @inheritParams type-predicates | ||||||||
| #' @seealso [type-predicates], [scalar-type-predicates] | ||||||||
| #' @name bare-type-predicates | ||||||||
| NULL | ||||||||
| #' @export | ||||||||
| #' @rdname bare-type-predicates | ||||||||
| is_bare_list <- function(x, n = NULL) { | ||||||||
| !is.object(x) && is_list(x, n) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname bare-type-predicates | ||||||||
| is_bare_atomic <- function(x, n = NULL) { | ||||||||
| !is.object(x) && is_atomic(x, n) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname bare-type-predicates | ||||||||
| is_bare_vector <- function(x, n = NULL) { | ||||||||
| is_bare_atomic(x) || is_bare_list(x, n) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname bare-type-predicates | ||||||||
| is_bare_double <- function(x, n = NULL) { | ||||||||
| !is.object(x) && is_double(x, n) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname bare-type-predicates | ||||||||
| is_bare_integer <- function(x, n = NULL) { | ||||||||
| !is.object(x) && is_integer(x, n) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname bare-type-predicates | ||||||||
| is_bare_numeric <- function(x, n = NULL) { | ||||||||
| if (!is_null(n) && length(x) != n) return(FALSE) | ||||||||
| !is.object(x) && typeof(x) %in% c("double", "integer") | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname bare-type-predicates | ||||||||
| is_bare_character <- function(x, n = NULL) { | ||||||||
| !is.object(x) && is_character(x, n) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname bare-type-predicates | ||||||||
| is_bare_logical <- function(x, n = NULL) { | ||||||||
| !is.object(x) && is_logical(x, n) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname bare-type-predicates | ||||||||
| is_bare_raw <- function(x, n = NULL) { | ||||||||
| !is.object(x) && is_raw(x, n) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname bare-type-predicates | ||||||||
| is_bare_string <- function(x, n = NULL) { | ||||||||
| !is.object(x) && is_string(x, n) | ||||||||
| } | ||||||||
| #' @export | ||||||||
| #' @rdname bare-type-predicates | ||||||||
| is_bare_bytes <- is_bare_raw | ||||||||
| #' Is object an empty vector or NULL? | ||||||||
| #' | ||||||||
| #' @param x object to test | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' is_empty(NULL) | ||||||||
| #' is_empty(list()) | ||||||||
| #' is_empty(list(NULL)) | ||||||||
| is_empty <- function(x) length(x) == 0 | ||||||||
| #' Is object an environment? | ||||||||
| #' | ||||||||
| #' `is_bare_environment()` tests whether `x` is an environment without a s3 or | ||||||||
| #' s4 class. | ||||||||
| #' | ||||||||
| #' @inheritParams is_empty | ||||||||
| #' @export | ||||||||
| is_environment <- function(x) { | ||||||||
| typeof(x) == "environment" | ||||||||
| } | ||||||||
| #' @rdname is_environment | ||||||||
| #' @export | ||||||||
| is_bare_environment <- function(x) { | ||||||||
| !is.object(x) && typeof(x) == "environment" | ||||||||
| } | ||||||||
| #' Is object identical to TRUE or FALSE? | ||||||||
| #' | ||||||||
| #' These functions bypass R's automatic conversion rules and check | ||||||||
| #' that `x` is literally `TRUE` or `FALSE`. | ||||||||
| #' @inheritParams is_empty | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' is_true(TRUE) | ||||||||
| #' is_true(1) | ||||||||
| #' | ||||||||
| #' is_false(FALSE) | ||||||||
| #' is_false(0) | ||||||||
| is_true <- function(x) { | ||||||||
| identical(x, TRUE) | ||||||||
| } | ||||||||
| #' @rdname is_true | ||||||||
| #' @export | ||||||||
| is_false <- function(x) { | ||||||||
| identical(x, FALSE) | ||||||||
| } | ||||||||
| #' Is a vector integer-like? | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' These predicates check whether R considers a number vector to be | ||||||||
| #' integer-like, according to its own tolerance check (which is in | ||||||||
| #' fact delegated to the C library). This function is not adapted to | ||||||||
| #' data analysis, see the help for [base::is.integer()] for examples | ||||||||
| #' of how to check for whole numbers. | ||||||||
| #' | ||||||||
| #' Things to consider when checking for integer-like doubles: | ||||||||
| #' | ||||||||
| #' * This check can be expensive because the whole double vector has | ||||||||
| #' to be traversed and checked. | ||||||||
| #' | ||||||||
| #' * Large double values may be integerish but may still not be | ||||||||
| #' coercible to integer. This is because integers in R only support | ||||||||
| #' values up to `2^31 - 1` while numbers stored as double can be | ||||||||
| #' much larger. | ||||||||
| #' | ||||||||
| #' @seealso [is_bare_numeric()] for testing whether an object is a | ||||||||
| #' base numeric type (a bare double or integer vector). | ||||||||
| #' @inheritParams type-predicates | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' is_integerish(10L) | ||||||||
| #' is_integerish(10.0) | ||||||||
| #' is_integerish(10.0, n = 2) | ||||||||
| #' is_integerish(10.000001) | ||||||||
| #' is_integerish(TRUE) | ||||||||
| is_integerish <- function(x, n = NULL, finite = NULL) { | ||||||||
| .Call(rlang_is_integerish, x, n, finite) | ||||||||
| } | ||||||||
| #' @rdname is_integerish | ||||||||
| #' @export | ||||||||
| is_bare_integerish <- function(x, n = NULL, finite = NULL) { | ||||||||
| !is.object(x) && is_integerish(x, n, finite) | ||||||||
| } | ||||||||
| #' @rdname is_integerish | ||||||||
| #' @export | ||||||||
| is_scalar_integerish <- function(x, finite = NULL) { | ||||||||
| .Call(rlang_is_integerish, x, 1L, finite) | ||||||||
| } | ||||||||
| type_of_ <- function(x) { | ||||||||
| type <- typeof(x) | ||||||||
| if (is_formulaish(x)) { | ||||||||
| if (identical(node_car(x), colon_equals_sym)) { | ||||||||
| "definition" | ||||||||
| } else { | ||||||||
| "formula" | ||||||||
| } | ||||||||
| } else if (type == "character") { | ||||||||
| if (length(x) == 1) "string" else "character" | ||||||||
| } else if (type %in% c("builtin", "special")) { | ||||||||
| "primitive" | ||||||||
| } else { | ||||||||
| type | ||||||||
| } | ||||||||
| } | ||||||||
| #' Format a type for error messages | ||||||||
| #' | ||||||||
| #' @section Life cycle: | ||||||||
| #' | ||||||||
| #' * `friendly_type()` is experimental. | ||||||||
| #' | ||||||||
| #' @param type A type as returned by [typeof()]. | ||||||||
| #' @return A string of the prettified type, qualified with an | ||||||||
| #' indefinite article. | ||||||||
| #' @export | ||||||||
| #' @keywords internal | ||||||||
| #' @examples | ||||||||
| #' friendly_type("logical") | ||||||||
| #' friendly_type("integer") | ||||||||
| #' friendly_type("string") | ||||||||
| #' @export | ||||||||
| friendly_type <- function(type) { | ||||||||
| as_friendly_type(type) %||% type | ||||||||
| } | ||||||||
| #' Is an object copyable? | ||||||||
| #' | ||||||||
| #' When an object is modified, R generally copies it (sometimes | ||||||||
| #' lazily) to enforce [value | ||||||||
| #' semantics](https://en.wikipedia.org/wiki/Value_semantics). | ||||||||
| #' However, some internal types are uncopyable. If you try to copy | ||||||||
| #' them, either with `<-` or by argument passing, you actually create | ||||||||
| #' references to the original object rather than actual | ||||||||
| #' copies. Modifying these references can thus have far reaching side | ||||||||
| #' effects. | ||||||||
| #' | ||||||||
| #' @param x An object to test. | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # Let's add attributes with structure() to uncopyable types. Since | ||||||||
| #' # they are not copied, the attributes are changed in place: | ||||||||
| #' env <- env() | ||||||||
| #' structure(env, foo = "bar") | ||||||||
| #' env | ||||||||
| #' | ||||||||
| #' # These objects that can only be changed with side effect are not | ||||||||
| #' # copyable: | ||||||||
| #' is_copyable(env) | ||||||||
| #' | ||||||||
| #' structure(base::list, foo = "bar") | ||||||||
| #' str(base::list) | ||||||||
| is_copyable <- function(x) { | ||||||||
| switch(typeof(x), | ||||||||
| NULL = , | ||||||||
| char = , | ||||||||
| symbol = , | ||||||||
| special = , | ||||||||
| builtin = , | ||||||||
| environment = , | ||||||||
| externalptr = | ||||||||
| FALSE, | ||||||||
| TRUE | ||||||||
| ) | ||||||||
| } | ||||||||
| is_equal <- function(x, y) { | ||||||||
| identical(x, y) | ||||||||
| } | ||||||||
| #' Is an object referencing another? | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' | ||||||||
| #' There are typically two situations where two symbols may refer to | ||||||||
| #' the same object. | ||||||||
| #' | ||||||||
| #' * R objects usually have copy-on-write semantics. This is an | ||||||||
| #' optimisation that ensures that objects are only copied if | ||||||||
| #' needed. When you copy a vector, no memory is actually copied | ||||||||
| #' until you modify either the original object or the copy is | ||||||||
| #' modified. | ||||||||
| #' | ||||||||
| #' Note that the copy-on-write optimisation is an implementation | ||||||||
| #' detail that is not guaranteed by the specification of the R | ||||||||
| #' language. | ||||||||
| #' | ||||||||
| #' * Assigning an [uncopyable][is_copyable] object (like an | ||||||||
| #' environment) creates a reference. These objects are never copied | ||||||||
| #' even if you modify one of the references. | ||||||||
| #' | ||||||||
| #' @param x,y R objects. | ||||||||
| #' @keywords internal | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # Reassigning an uncopyable object such as an environment creates a | ||||||||
| #' # reference: | ||||||||
| #' env <- env() | ||||||||
| #' ref <- env | ||||||||
| #' is_reference(ref, env) | ||||||||
| #' | ||||||||
| #' # Due to copy-on-write optimisation, a copied vector can | ||||||||
| #' # temporarily reference the original vector: | ||||||||
| #' vec <- 1:10 | ||||||||
| #' copy <- vec | ||||||||
| #' is_reference(copy, vec) | ||||||||
| #' | ||||||||
| #' # Once you modify on of them, the copy is triggered in the | ||||||||
| #' # background and the objects cease to reference each other: | ||||||||
| #' vec[[1]] <- 100 | ||||||||
| #' is_reference(copy, vec) | ||||||||
| is_reference <- function(x, y) { | ||||||||
| .Call(rlang_is_reference, x, y) | ||||||||
| } | ||||||||
| # Use different generic name to avoid import warnings when loading | ||||||||
| # packages that import all of rlang after it has been load_all'd | ||||||||
| rlang_type_sum <- function(x) { | ||||||||
| if (is_installed("pillar")) { | ||||||||
| pillar::type_sum(x) | ||||||||
| } else { | ||||||||
| UseMethod("rlang_type_sum") | ||||||||
| } | ||||||||
| } | ||||||||
| #' @export | ||||||||
| rlang_type_sum.ordered <- function(x) "ord" | ||||||||
| #' @export | ||||||||
| rlang_type_sum.factor <- function(x) "fct" | ||||||||
| #' @export | ||||||||
| rlang_type_sum.POSIXct <- function(x) "dttm" | ||||||||
| #' @export | ||||||||
| rlang_type_sum.difftime <- function(x) "time" | ||||||||
| #' @export | ||||||||
| rlang_type_sum.Date <- function(x) "date" | ||||||||
| #' @export | ||||||||
| rlang_type_sum.data.frame <- function(x) class(x)[[1]] | ||||||||
| #' @export | ||||||||
| rlang_type_sum.default <- function(x) { | ||||||||
| if (!is.object(x)) { | ||||||||
| switch(typeof(x), | ||||||||
| logical = "lgl", | ||||||||
| integer = "int", | ||||||||
| double = "dbl", | ||||||||
| character = "chr", | ||||||||
| complex = "cpl", | ||||||||
| builtin = , | ||||||||
| special = , | ||||||||
| closure = "fn", | ||||||||
| environment = "env", | ||||||||
| symbol = | ||||||||
| if (is_missing(x)) { | ||||||||
| "missing" | ||||||||
| } else { | ||||||||
| "sym" | ||||||||
| }, | ||||||||
| typeof(x) | ||||||||
| ) | ||||||||
| } else if (!isS4(x)) { | ||||||||
| paste0("S3: ", class(x)[[1]]) | ||||||||
| } else { | ||||||||
| paste0("S4: ", methods::is(x)[[1]]) | ||||||||
| } | ||||||||
| } | ||||||||
| tibble/R/new.R | Memory | Time | ||||||
|---|---|---|---|---|---|---|---|---|
| #' Tibble constructor and validator | ||||||||
| #' | ||||||||
| #' @description | ||||||||
| #' `r lifecycle::badge("maturing")` | ||||||||
| #' | ||||||||
| #' Creates or validates a subclass of a tibble. | ||||||||
| #' These function is mostly useful for package authors that implement subclasses | ||||||||
| #' of a tibble, like \pkg{sf} or \pkg{tsibble}. | ||||||||
| #' | ||||||||
| #' `new_tibble()` creates a new object as a subclass of `tbl_df`, `tbl` and `data.frame`. | ||||||||
| #' This function is optimized for performance, checks are reduced to a minimum. | ||||||||
| #' | ||||||||
| #' @param x A tibble-like object. | ||||||||
| #' @param ... Name-value pairs of additional attributes. | ||||||||
| #' @param nrow The number of rows, required. | ||||||||
| #' @param class Subclasses to assign to the new object, default: none. | ||||||||
| #' @param subclass Deprecated, retained for compatibility. Please use the `class` argument. | ||||||||
| #' | ||||||||
| #' @seealso | ||||||||
| #' [tibble()] and [as_tibble()] for ways to construct a tibble | ||||||||
| #' with recycling of scalars and automatic name repair. | ||||||||
| #' | ||||||||
| #' @export | ||||||||
| #' @examples | ||||||||
| #' # The nrow argument is always required: | ||||||||
| #' new_tibble(list(a = 1:3, b = 4:6), nrow = 3) | ||||||||
| #' | ||||||||
| #' # Existing row.names attributes are ignored: | ||||||||
| #' try(new_tibble(iris, nrow = 3)) | ||||||||
| #' | ||||||||
| #' # The length of all columns must be compatible with the nrow argument: | ||||||||
| #' try(new_tibble(list(a = 1:3, b = 4:6), nrow = 2)) | ||||||||
| new_tibble <- function(x, ..., nrow, class = NULL, subclass = NULL) { | ||||||||
| # For compatibility with tibble < 2.0.0 | ||||||||
| if (is.null(class) && !is.null(subclass)) { | ||||||||
| deprecate_soft("2.0.0", "tibble::new_tibble(subclass = )", "new_tibble(class = )") | ||||||||
| class <- subclass | ||||||||
| } | ||||||||
| #' @section Construction: | ||||||||
| #' | ||||||||
| #' For `new_tibble()`, `x` must be a list. | ||||||||
| x <- unclass(x) | ||||||||
| if (!is.list(x)) { | ||||||||
| cnd_signal(error_new_tibble_must_be_list()) | ||||||||
| } | ||||||||
| #' The `...` argument allows adding more attributes to the subclass. | ||||||||
| x <- update_tibble_attrs(x, ...) | ||||||||
| #' An `nrow` argument is required. | ||||||||
| if (missing(nrow)) { | ||||||||
| cnd <- error_new_tibble_needs_nrow() | ||||||||
| if (length(x) >= 1) { | ||||||||
| deprecate_soft("2.0.0", "tibble::new_tibble(nrow = 'can\\'t be missing')", | ||||||||
| details = cnd$message) | ||||||||
| nrow <- vec_size(x[[1]]) | ||||||||
| } else { | ||||||||
| cnd_signal(cnd) | ||||||||
| } | ||||||||
| } | ||||||||
| #' This should be an integer of length 1, | ||||||||
| #' and every element of the list `x` should have [vctrs::vec_size()] | ||||||||
| #' equal to this value. | ||||||||
| #' (But this is not checked by the constructor). | ||||||||
| #' This takes the place of the "row.names" attribute in a data frame. | ||||||||
| if (!is_integerish(nrow, 1)) { | ||||||||
| cnd_signal(error_new_tibble_needs_nrow()) | ||||||||
| } | ||||||||
| #' `x` must have names (or be empty), | ||||||||
| #' but the names are not checked for correctness. | ||||||||
| if (length(x) == 0) { | ||||||||
| # Leaving this because creating a named list of length zero seems difficult | ||||||||
| names(x) <- character() | ||||||||
| } else if (is.null(names(x))) { | ||||||||
| cnd_signal(error_names_must_be_non_null()) | ||||||||
| } | ||||||||
| set_tibble_subclass(x, nrow, class) | ||||||||
| } | ||||||||
| #' @description | ||||||||
| #' `validate_tibble()` checks a tibble for internal consistency. | ||||||||
| #' Correct behavior can be guaranteed only if this function | ||||||||
| #' runs without raising an error. | ||||||||
| #' | ||||||||
| #' @rdname new_tibble | ||||||||
| #' @export | ||||||||
| validate_tibble <- function(x) { | ||||||||
| #' @section Validation: | ||||||||
| #' `validate_tibble()` checks for "minimal" names | ||||||||
| check_minimal_names(x) | ||||||||
| #' and that all columns are vectors, data frames or matrices. | ||||||||
| check_valid_cols(unclass(x)) | ||||||||
| #' It also makes sure that all columns have the same length, | ||||||||
| #' and that [vctrs::vec_size()] is consistent with the data. | ||||||||
| validate_nrow(names(x), col_lengths(x), vec_size(x)) | ||||||||
| x | ||||||||
| } | ||||||||
| cnd_signal_if <- function(x) { | ||||||||
| if (!is.null(x)) { | ||||||||
| cnd_signal(x) | ||||||||
| } | ||||||||
| } | ||||||||
| check_minimal <- function(name) { | ||||||||
| cnd_signal_if(cnd_names_non_null(name)) | ||||||||
| cnd_signal_if(cnd_names_non_na(name)) | ||||||||
| } | ||||||||
| check_minimal_names <- function(x) { | ||||||||
| check_minimal(names(x)) | ||||||||
| invisible(x) | ||||||||
| } | ||||||||
| col_lengths <- function(x) { | ||||||||
| map_int(x, vec_size) | ||||||||
| } | ||||||||
| validate_nrow <- function(names, lengths, nrow) { | ||||||||
| # Validate column lengths, don't recycle | ||||||||
| bad_len <- which(lengths != nrow) | ||||||||
| if (has_length(bad_len)) { | ||||||||
| cnd_signal(error_incompatible_size(nrow, names, lengths, "Requested with `nrow` argument")) | ||||||||
| } | ||||||||
| } | ||||||||
| update_tibble_attrs <- function(x, ...) { | ||||||||
| .Call(`tibble_update_attrs`, x, pairlist2(...)) | ||||||||
| } | ||||||||
| tibble_class <- c("tbl_df", "tbl", "data.frame") | ||||||||
| # Two dedicated functions for faster creation | ||||||||
| set_tibble_subclass <- function(x, nrow, subclass) { | ||||||||
| attr(x, "row.names") <- .set_row_names(nrow) | ||||||||
| class(x) <- c(setdiff(subclass, tibble_class), tibble_class) | ||||||||
| x | ||||||||
| } | ||||||||
| # Errors ------------------------------------------------------------------ | ||||||||
| error_new_tibble_must_be_list <- function() { | ||||||||
| tibble_error("`x` must be a list.") | ||||||||
| } | ||||||||
| error_new_tibble_needs_nrow <- function() { | ||||||||
| tibble_error("`x` must be a scalar integer.") | ||||||||
| } | ||||||||
In general, a minimal plot is used so that profiles are focused on low-level, general code, rather than implementations of specific geoms. This might be expanded at the point where improving performance of specific geoms becomes a focus. Further, the profile focuses on the steps up until a final gtable have been constructed. Any performance problems in rendering is likely due to grid and the device, more than ggplot2.
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 ggplot2 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:
v3.3.3
-
Avoid costly factor construction in scale_apply This issue only really appeared when plotting huge datasets (>1e6 rows). In order to train and map the position aesthetics rows has to be matched based on their panel. This require splitting the row indexes by panel which included a
factor()call. The factor constructor is very slow for large vectors and can be simplified considerably for this specific case. Further, the split can be avoided completely when there is only one panel
v3.1.0
-
Caching of calls to
grid::descentDetails()The absolute biggest offender was the construction of titles. In recent versions this has included calls togrid::descentDetails()to ensure that they are aligned across plots, but this is quite heavy. These calls are now cached so they only have to be calculated once per font setting. -
Use a performant
data.frameconstructor throughout the codebase Thedata.frame()function carries a lot of overhead in order to sanitize and check the input. This is generally not needed if you are sure about the input and will just lead to slower code. Thedata.frame()call is now only used when dealing with output from other packages where the extra safety is a benefit. -
Use a performant alternative to
utils::modifyListmodifyList()is a nice convenience function but carries a lot of overhead. It was mainly used in the plot element constructions where it slowed down the application of theme settings. A more performant version has been added and used throughout. -
Speed up position transformation The
transform_positionhelper was unreasonably slow due to the slowness of getting and assigning columns in data.frame. The input is now treated as a list during transformation.