Why do some function calls not show in the profiler?

As noted earlier, some of R’s built-in functions don’t show in the profvis flame graph. These include functions like <-, [, and $. Although these functions can occupy a lot of time, they don’t show on the call stack. (In one of the examples above, $ does show on the call stack, but this is because it was dispatched to $.data.frame, as opposed to R’s internal C code, which is used for indexing into lists.)

In some cases the side-effects of these functions can be seen in the flamegraph. As we saw in the example above, using these functions in a loop led to many memory allocations, which led to garbage collections, or <GC> blocks in the flame graph.

How do I share a profvis visualization?

Right now the easiest way to do this is to run profvis in RStudio, and publish to RPubs.

Once the profile shows up in the RStudio IDE, click on the Publish button to send it to RPubs. You can see an example here. If you don’t already have an account on RPubs, you’ll need to set one up.

You can also click on the save (disk) icon. This will save the profvis visualization to an .Rprofvis file. This file can be opened by RStudio, or if you rename it to have an .html extension, it can be opened in a web browser.

Publishing to RPubs

Another way to publish a profvis visualization is to save the HTML output file using htmlwidgets::saveWidget, and put that on any web hosting service:

p <- profvis({
  # Interesting code here
})

htmlwidgets::saveWidget(p, "profile.html")

It’s also possible to put a profvis visualization in a knitr document. At this time, some CSS workarounds are needed needed for them to display properly. You can look at the source of this website to see the workarounds.

What does <Anonymous> mean?

It’s not uncommon for R code to contain anonymous functions – that is, functions that aren’t named. These show up as <Anonymous> in the profiling data collected from Rprof.

In the code below there is a function, make_adder, that returns a function. We’ll invoke the returned function in two ways.

First, we’ll run make_adder(1)(10). The call make_adder(1) returns a function, which is invoked immediately (without being saved in a variable), and shows up as <Anonymous> in the flame graph.

Next, we’ll call make_adder(2) but this time, we’ll save the result in a variable, adder2. Then we’ll call adder2(10). When we do it this way, the profiler records that the function label is adder2.

profvis({
  make_adder <- function(n) {
    function(x) {
      pause(0.25) # Wait for a moment so that this shows in the profiler
      x + n
    }
  }

  # Called with no intermediate variable, it shows as "<Anonymous>"
  make_adder(1)(10)

  # With the function saved in a variable, it shows as "adder2"
  adder2 <- make_adder(2)
  adder2(10)
})
Flame Graph
Data
Options ▾
<expr>MemoryTime
profvis({
make_adder <- function(n) {
function(x) {
pause(0.25) # Wait for a moment so that this shows in the profiler
x + n
}
}
# Called with no intermediate variable, it shows as "<Anonymous>"
make_adder(1)(10)
# With the function saved in a variable, it shows as "adder2"
adder2 <- make_adder(2)
adder2(10)
})
<Anonymous>pauseadder2pause050100150200250300350400
Sample Interval: 10ms
420ms

Similarly, in versions of R before 3.3.0, functions that are accessed with :: or $ will also appear as <Anonymous>. The form package::function() is a common way to explicitly use a namespace to find a function. The form x$fun() is a common way to call functions that are contained in a list, environment, reference class, or R6 object. As of R 3.3.0, these will display as package::function, or x$fun.

Those are equivalent to `::`(package, function) and `$`(x, "fun"), respectively. These calls return anonymous functions, and so R’s internal profiling code labels these as <Anonymous>. If you want labels in the profiler to have a different label, you can assign the value to a temporary variable (like adder2 above), and then invoke that.

Finally, if a function is passed to lapply, it will be show up as FUN in the flame graph. If we inspect the source code for lapply, it’s clear why: when a function is passed to lapply, the name used for the function inside of lapply is FUN.

lapply
#> function (X, FUN, ...) 
#> {
#>     FUN <- match.fun(FUN)
#>     if (!is.vector(X) || is.object(X)) 
#>         X <- as.list(X)
#>     .Internal(lapply(X, FUN))
#> }
#> <bytecode: 0x7fa19d09efc0>
#> <environment: namespace:base>

What does cmpfun mean?

The first time we run profvis on a function in a clean 3.4.0 or greater R session, we’ll see compiler:::tryCmpfun. For example,

profvis({
  data <- data.frame(value = runif(5e4))
  
  csum <- function(x) {
    if (length(x) < 2) return(x)

    sum <- x[1]
    for (i in seq(2, length(x))) {
      sum[i] <- sum[i-1] + x[i]
    }
    sum
  }
  data$sum <- csum(data$value)
})
Flame Graph
Data
Options ▾
<expr>MemoryTime
p <- profvis::profvis({
data <- data.frame(value = runif(5e4))
csum <- function(x) {
if (length(x) < 2) return(x)
sum <- x[1]
for (i in seq(2, length(x))) {
sum[i] <- sum[i-1] + x[i]
}
sum
}
data$sum <- csum(data$value)
})
csumcompiler:::tryCmpfuntryCatchtryCatchListtryCatchOnedoTryCatchcmpfungenCodemake.codeBufcmpsum[i] <- sum[i-1] + x[i]051015202530354045505560
Sample Interval: 10ms
60ms

As of R 3.4.0, R attempts to compile functions when they are first ran to byte code. On subsequent function calls, instead of reinterpreting the body of the function, R executes the saved and compiled byte code. Typically, this results in faster execution times on later function calls. For example, let’s profile csum a second time in the same R session:

Flame Graph
Data
Options ▾
<expr>MemoryTime
p <- profvis::profvis({
data <- data.frame(value = runif(5e4))
csum <- function(x) {
if (length(x) < 2) return(x)
sum <- x[1]
for (i in seq(2, length(x))) {
sum[i] <- sum[i-1] + x[i]
}
sum
}
data$sum <- csum(data$value)
})
csumsum[i] <- sum[i-1] + x[i]02468101214161820
Sample Interval: 10ms
20ms

Now the flame graph shows that the function is no longer being compiled. And after compiling, csum is about 40 ms faster.

How do I get code from an R package to show in the code panel?

In typical use, only code written by the user is shown in the code panel. (This is code for which source references are available.) Yellow blocks in the flame graph have corresponding lines of code in the code panel, and when moused over, the line of code will be highlighted. White blocks in the flame graph don’t have corresponding lines in the code panel. In most cases, the calls represented by the white blocks are to functions that are in base R and other packages.

Profvis can also show code that’s inside an R package. To do this, source refs for the package code must be available. There are two general ways to do this: you can install the package with source refs, or you can use devtools::load_all() to load a package from sources on disk.

Installing with source refs

There are many ways to install a package with source refs. Here are some examples of installing ggplot2:

  • From CRAN:

    ## First, restart R ##
install.packages("ggplot2", type="source", INSTALL_opts="--with-keep.source")

  • From an RStudio package project on local disk: Go to Build -> Configure Build Tools -> Build Tools -> Build and Reload – R CMD INSTALL additional options, and add --with-keep.source. Then run Build -> Build and Reload.

  • From sources on disk with devtools:

    ## First, restart R ##
# Assuming sources are in a subdirectory ggplot2/
devtools::install("ggplot2", keep_source = TRUE)

  • From sources on disk using the command line:

    R CMD INSTALL --with-keep.source ggplot2/

  • From sources on Github:

    ## First, restart R ##
remotes::install_github("hadley/ggplot2", INSTALL_opts="--with-keep.source")

Loading packages with source refs (without installing)

  • Instead of installing an in-development package, you can simply load it from source using devtools.

    # Assuming sources are in a subdirectory ggplot2/
devtools::load_all("ggplot2")

Once a package is loaded or installed with source refs, profvis visualizations will display source code for that package. For example, the visualization below has yellow blocks for both user code and for code in ggplot2, and it contains ggplot2 code in the code panel:

library(ggplot2)
profvis({
  g <- ggplot(diamonds, aes(carat, price)) + geom_point(size = 1, alpha = 0.2)
  print(g)
})
Flame Graph
Data
Options ▾
<expr>MemoryTime
p <- profvis({
g <- ggplot(diamonds, aes(carat, price)) + geom_point(size = 1, alpha = 0.2)
print(g)
})
ggplot2/R/plot.rMemoryTime
#' Create a new ggplot
#'
#' \code{ggplot()} initializes a ggplot object. It can be used to
#' declare the input data frame for a graphic and to specify the
#' set of plot aesthetics intended to be common throughout all
#' subsequent layers unless specifically overridden.
#'
#' \code{ggplot()} is used to construct the initial plot object,
#' and is almost always followed by \code{+} to add component to the
#' plot. There are three common ways to invoke \code{ggplot}:
#'
#' \enumerate{
#' \item \code{ggplot(df, aes(x, y, <other aesthetics>))}
#' \item \code{ggplot(df)}
#' \item \code{ggplot()}
#' }
#'
#' The first method is recommended if all layers use the same
#' data and the same set of aesthetics, although this method
#' can also be used to add a layer using data from another
#' data frame. See the first example below. The second
#' method specifies the default data frame to use for the plot,
#' but no aesthetics are defined up front. This is useful when
#' one data frame is used predominantly as layers are added,
#' but the aesthetics may vary from one layer to another. The
#' third method initializes a skeleton \code{ggplot} object which
#' is fleshed out as layers are added. This method is useful when
#' multiple data frames are used to produce different layers, as
#' is often the case in complex graphics.
#'
#' @param data Default dataset to use for plot. If not already a data.frame,
#' will be converted to one by \code{\link{fortify}}. If not specified,
#' must be suppled in each layer added to the plot.
#' @param mapping Default list of aesthetic mappings to use for plot.
#' If not specified, must be suppled in each layer added to the plot.
#' @param ... Other arguments passed on to methods. Not currently used.
#' @param environment If an variable defined in the aesthetic mapping is not
#' found in the data, ggplot will look for it in this environment. It defaults
#' to using the environment in which \code{ggplot()} is called.
#' @export
#' @examples
#' # Generate some sample data, then compute mean and standard deviation
#' # in each group
#' df <- data.frame(
#' gp = factor(rep(letters[1:3], each = 10)),
#' y = rnorm(30)
#' )
#' ds <- plyr::ddply(df, "gp", plyr::summarise, mean = mean(y), sd = sd(y))
#'
#' # The summary data frame ds is used to plot larger red points on top
#' # of the raw data. Note that we don't need to supply `data` or `mapping`
#' # in each layer because the defaults from ggplot() are used.
#' ggplot(df, aes(gp, y)) +
#' geom_point() +
#' geom_point(data = ds, aes(y = mean), colour = 'red', size = 3)
#'
#' # Same plot as above, declaring only the data frame in ggplot().
#' # Note how the x and y aesthetics must now be declared in
#' # each geom_point() layer.
#' ggplot(df) +
#' geom_point(aes(gp, y)) +
#' geom_point(data = ds, aes(gp, mean), colour = 'red', size = 3)
#'
#' # Alternatively we can fully specify the plot in each layer. This
#' # is not useful here, but can be more clear when working with complex
#' # mult-dataset graphics
#' ggplot() +
#' geom_point(data = df, aes(gp, y)) +
#' geom_point(data = ds, aes(gp, mean), colour = 'red', size = 3) +
#' geom_errorbar(
#' data = ds,
#' aes(gp, mean, ymin = mean - sd, ymax = mean + sd),
#' colour = 'red',
#' width = 0.4
#' )
ggplot <- function(data = NULL, mapping = aes(), ...,
environment = parent.frame()) {
UseMethod("ggplot")
}
#' @export
ggplot.default <- function(data = NULL, mapping = aes(), ...,
environment = parent.frame()) {
ggplot.data.frame(fortify(data, ...), mapping, environment = environment)
}
#' @export
ggplot.data.frame <- function(data, mapping = aes(), ...,
environment = parent.frame()) {
if (!missing(mapping) && !inherits(mapping, "uneval")) {
stop("Mapping should be created with `aes() or `aes_()`.", call. = FALSE)
}
p <- structure(list(
data = data,
layers = list(),
scales = scales_list(),
mapping = mapping,
theme = list(),
coordinates = coord_cartesian(),
facet = facet_null(),
plot_env = environment
), class = c("gg", "ggplot"))
p$labels <- make_labels(mapping)
set_last_plot(p)
p
}
plot_clone <- function(plot) {
p <- plot
p$scales <- plot$scales$clone()
p
}
#' Reports whether x is a ggplot object
#' @param x An object to test
#' @keywords internal
#' @export
is.ggplot <- function(x) inherits(x, "ggplot")
#' Explicitly draw plot
#'
#' Generally, you do not need to print or plot a ggplot2 plot explicitly: the
#' default top-level print method will do it for you. You will, however, need
#' to call \code{print()} explicitly if you want to draw a plot inside a
#' function or for loop.
#'
#' @param x plot to display
#' @param newpage draw new (empty) page first?
#' @param vp viewport to draw plot in
#' @param ... other arguments not used by this method
#' @keywords hplot
#' @return Invisibly returns the result of \code{\link{ggplot_build}}, which
#' is a list with components that contain the plot itself, the data,
#' information about the scales, panels etc.
#' @export
#' @method print ggplot
#' @examples
#' colours <- list(~class, ~drv, ~fl)
#'
#' # Doesn't seem to do anything!
#' for (colour in colours) {
#' ggplot(mpg, aes_(~ displ, ~ hwy, colour = colour)) +
#' geom_point()
#' }
#'
#' # Works when we explicitly print the plots
#' for (colour in colours) {
#' print(ggplot(mpg, aes_(~ displ, ~ hwy, colour = colour)) +
#' geom_point())
#' }
print.ggplot <- function(x, newpage = is.null(vp), vp = NULL, ...) {
set_last_plot(x)
if (newpage) grid.newpage()
# Record dependency on 'ggplot2' on the display list
# (AFTER grid.newpage())
grDevices::recordGraphics(
requireNamespace("ggplot2", quietly = TRUE),
list(),
getNamespace("ggplot2")
)
data <- ggplot_build(x)
gtable <- ggplot_gtable(data)
if (is.null(vp)) {
grid.draw(gtable)
} else {
if (is.character(vp)) seekViewport(vp) else pushViewport(vp)
grid.draw(gtable)
upViewport()
}
invisible(data)
}
#' @rdname print.ggplot
#' @method plot ggplot
#' @export
plot.ggplot <- print.ggplot
ggplot2/R/scale-type.RMemoryTime
find_scale <- function(aes, x, env = parent.frame()) {
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 type of a scale
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.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/layer.rMemoryTime
#' Create a new layer
#'
#' A layer is a combination of data, stat and geom with a potential position
#' adjustment. Usually layers are created using \code{geom_*} or \code{stat_*}
#' calls but it can also be created directly using this function.
#'
#' @export
#' @inheritParams geom_point
#' @param mapping Set of aesthetic mappings created by \code{\link{aes}} or
#' \code{\link{aes_}}. If specified and \code{inherit.aes = TRUE} (the
#' default), it is combined with the default mapping at the top level of the
#' plot. You must supply \code{mapping} if there is no plot mapping.
#' @param data The data to be displayed in this layer. There are three
#' options:
#'
#' If \code{NULL}, the default, the data is inherited from the plot
#' data as specified in the call to \code{\link{ggplot}}.
#'
#' A \code{data.frame}, or other object, will override the plot
#' data. All objects will be fortified to produce a data frame. See
#' \code{\link{fortify}} for which variables will be created.
#'
#' A \code{function} will be called with a single argument,
#' the plot data. The return value must be a \code{data.frame.}, and
#' will be used as the layer data.
#' @param geom The geometric object to use display the data
#' @param stat The statistical transformation to use on the data for this
#' layer, as a string.
#' @param position Position adjustment, either as a string, or the result of
#' a call to a position adjustment function.
#' @param show.legend logical. Should this layer be included in the legends?
#' \code{NA}, the default, includes if any aesthetics are mapped.
#' \code{FALSE} never includes, and \code{TRUE} always includes.
#' @param inherit.aes If \code{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. \code{\link{borders}}.
#' @param check.aes,check.param If \code{TRUE}, the default, will check that
#' supplied parameters and aesthetics are understood by the \code{geom} or
#' \code{stat}. Use \code{FALSE} to suppress the checks.
#' @param params Additional parameters to the \code{geom} and \code{stat}.
#' @param subset DEPRECATED. An older way of subsetting the dataset used in a
#' layer.
#' @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,
subset = NULL, show.legend = NA) {
if (is.null(geom))
stop("Attempted to create layer with no geom.", call. = FALSE)
if (is.null(stat))
stop("Attempted to create layer with no stat.", call. = FALSE)
if (is.null(position))
stop("Attempted to create layer with no position.", call. = FALSE)
# Handle show_guide/show.legend
if (!is.null(params$show_guide)) {
warning("`show_guide` has been deprecated. Please use `show.legend` instead.",
call. = FALSE)
show.legend <- params$show_guide
params$show_guide <- NULL
}
if (!is.logical(show.legend) || length(show.legend) != 1) {
warning("`show.legend` must be a logical vector of length 1.", call. = FALSE)
show.legend <- FALSE
}
data <- fortify(data)
if (!is.null(mapping) && !inherits(mapping, "uneval")) {
stop("Mapping must be created by `aes()` or `aes_()`", call. = FALSE)
}
if (is.character(geom))
geom <- find_subclass("Geom", geom, parent.frame())
if (is.character(stat))
stat <- find_subclass("Stat", stat, parent.frame())
if (is.character(position))
position <- find_subclass("Position", position, parent.frame())
# Special case for na.rm parameter needed by all layers
if (is.null(params$na.rm)) {
params$na.rm <- FALSE
}
# Split up params between aesthetics, geom, and stat
params <- rename_aes(params)
aes_params <- params[intersect(names(params), geom$aesthetics())]
geom_params <- params[intersect(names(params), geom$parameters(TRUE))]
stat_params <- params[intersect(names(params), stat$parameters(TRUE))]
all <- c(geom$parameters(TRUE), stat$parameters(TRUE), geom$aesthetics())
# Warn about extra params and aesthetics
extra_param <- setdiff(names(params), all)
if (check.param && length(extra_param) > 0) {
warning(
"Ignoring unknown parameters: ", paste(extra_param, collapse = ", "),
call. = FALSE,
immediate. = TRUE
)
}
extra_aes <- setdiff(names(mapping), c(geom$aesthetics(), stat$aesthetics()))
if (check.aes && length(extra_aes) > 0) {
warning(
"Ignoring unknown aesthetics: ", paste(extra_aes, collapse = ", "),
call. = FALSE,
immediate. = TRUE
)
}
ggproto("LayerInstance", Layer,
geom = geom,
geom_params = geom_params,
stat = stat,
stat_params = stat_params,
data = data,
mapping = mapping,
aes_params = aes_params,
subset = subset,
position = position,
inherit.aes = inherit.aes,
show.legend = show.legend
)
}
Layer <- ggproto("Layer", NULL,
geom = NULL,
geom_params = NULL,
stat = NULL,
stat_params = NULL,
data = NULL,
aes_params = NULL,
mapping = NULL,
position = NULL,
inherit.aes = FALSE,
print = function(self) {
if (!is.null(self$mapping)) {
cat("mapping:", clist(self$mapping), "\n")
}
cat(snakeize(class(self$geom)[[1]]), ": ", clist(self$geom_params), "\n",
sep = "")
cat(snakeize(class(self$stat)[[1]]), ": ", clist(self$stat_params), "\n",
sep = "")
cat(snakeize(class(self$position)[[1]]), "\n")
},
layer_data = function(self, plot_data) {
if (is.waive(self$data)) {
plot_data
} else if (is.function(self$data)) {
data <- self$data(plot_data)
if (!is.data.frame(data)) {
stop("Data function must return a data.frame", call. = FALSE)
}
data
} else {
self$data
}
},
compute_aesthetics = function(self, data, plot) {
# For annotation geoms, it is useful to be able to ignore the default aes
if (self$inherit.aes) {
aesthetics <- defaults(self$mapping, plot$mapping)
} else {
aesthetics <- self$mapping
}
# Drop aesthetics that are set or calculated
set <- names(aesthetics) %in% names(self$aes_params)
calculated <- is_calculated_aes(aesthetics)
aesthetics <- aesthetics[!set & !calculated]
# Override grouping if set in layer
if (!is.null(self$geom_params$group)) {
aesthetics[["group"]] <- self$aes_params$group
}
# Old subsetting method
if (!is.null(self$subset)) {
include <- data.frame(plyr::eval.quoted(self$subset, data, plot$env))
data <- data[rowSums(include, na.rm = TRUE) == ncol(include), ]
}
scales_add_defaults(plot$scales, data, aesthetics, plot$plot_env)
# Evaluate and check aesthetics
aesthetics <- compact(aesthetics)
evaled <- lapply(aesthetics, eval, envir = data, enclos = plot$plot_env)
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 <- data.frame(evaled, stringsAsFactors = FALSE)
evaled <- add_group(evaled)
evaled
},
compute_statistic = function(self, data, layout) {
if (empty(data))
return(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(data.frame())
# Assemble aesthetics from layer, plot and stat mappings
aesthetics <- self$mapping
if (self$inherit.aes) {
aesthetics <- defaults(aesthetics, plot$mapping)
}
aesthetics <- defaults(aesthetics, self$stat$default_aes)
aesthetics <- compact(aesthetics)
new <- strip_dots(aesthetics[is_calculated_aes(aesthetics)])
if (length(new) == 0) return(data)
# Add map stat output to aesthetics
stat_data <- plyr::quickdf(lapply(new, eval, data, baseenv()))
names(stat_data) <- names(new)
# Add any new scales, if needed
scales_add_defaults(plot$scales, data, new, plot$plot_env)
# Transform the values, if the scale say it's ok
# (see stat_spoke for one exception)
if (self$stat$retransform) {
stat_data <- scales_transform_df(plot$scales, stat_data)
}
cunion(stat_data, data)
},
compute_geom_1 = function(self, data) {
if (empty(data)) return(data.frame())
data <- self$geom$setup_data(data, c(self$geom_params, self$aes_params))
check_required_aesthetics(
self$geom$required_aes,
c(names(data), names(self$aes_params)),
snake_class(self$geom)
)
data
},
compute_position = function(self, data, layout) {
if (empty(data)) return(data.frame())
params <- self$position$setup_params(data)
data <- self$position$setup_data(data, params)
self$position$compute_layer(data, params, layout)
},
compute_geom_2 = function(self, data) {
# Combine aesthetics, defaults, & params
if (empty(data)) return(data)
self$geom$use_defaults(data, self$aes_params)
},
finish_statistics = function(self, data) {
self$stat$finish_layer(data, self$stat_params)
},
draw_geom = function(self, data, layout, coord) {
if (empty(data)) {
n <- nrow(layout$panel_layout)
return(rep(list(zeroGrob()), n))
}
data <- self$geom$handle_na(data, self$geom_params)
self$geom$draw_layer(data, self$geom_params, layout, coord)
}
)
is.layer <- function(x) inherits(x, "Layer")
find_subclass <- function(super, class, env) {
name <- paste0(super, camelize(class, first = TRUE))
obj <- find_global(name, env = env)
if (is.null(name)) {
stop("No ", tolower(super), " called ", name, ".", call. = FALSE)
} else if (!inherits(obj, super)) {
stop("Found object is not a ", tolower(super), ".", call. = FALSE)
}
obj
}
ggplot2/R/geom-point.rMemoryTime
#' 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 \code{\link{geom_jitter}},
#' \code{\link{geom_count}}, or \code{\link{geom_bin2d}} is usually more
#' appropriate.
#'
#' The \emph{bubblechart} is a scatterplot with a third variable mapped to
#' the size of points. There are no special names for scatterplots where
#' another variable is mapped to point shape or colour, however.
#'
#' @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
#' \code{\link{geom_smooth}}, \code{\link{geom_quantile}} or
#' \code{\link{geom_density_2d}}. If you have few unique x values,
#' \code{\link{geom_boxplot}} may also be useful.
#'
#' Alternatively, you can
#' summarise the number of points at each location and display that in some
#' way, using \code{\link{geom_count}}, \code{\link{geom_hex}}, or
#' \code{\link{geom_density2d}}.
#'
#' Another technique is to make the points transparent (e.g.
#' \code{geom_point(alpha = 0.05)}) or very small (e.g.
#' \code{geom_point(shape = ".")}).
#'
#' @section Aesthetics:
#' \aesthetics{geom}{point}
#'
#' @inheritParams layer
#' @param na.rm If \code{FALSE}, the default, missing values are removed with
#' a warning. If \code{TRUE}, missing values are silently removed.
#' @param ... other arguments passed on to \code{\link{layer}}. These are
#' often aesthetics, used to set an aesthetic to a fixed value, like
#' \code{color = "red"} or \code{size = 3}. They may also be parameters
#' to the paired geom/stat.
#' @inheritParams layer
#' @export
#' @examples
#' p <- ggplot(mtcars, aes(wt, mpg))
#' p + geom_point()
#'
#' # Add aesthetic mappings
#' p + geom_point(aes(colour = factor(cyl)))
#' p + geom_point(aes(shape = factor(cyl)))
#' p + geom_point(aes(size = qsec))
#'
#' # Change scales
#' p + geom_point(aes(colour = cyl)) + scale_colour_gradient(low = "blue")
#' p + geom_point(aes(shape = factor(cyl))) + scale_shape(solid = FALSE)
#'
#' # 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)))
#'
#' # These extra layers don't usually appear in the legend, but we can
#' # force their inclusion
#' p + geom_point(colour = "black", size = 4.5, show.legend = TRUE) +
#' geom_point(colour = "pink", size = 4, show.legend = TRUE) +
#' 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_scales, coord, na.rm = FALSE) {
coords <- coord$transform(data, panel_scales)
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
)
ggplot2/R/aes.rMemoryTime
#' @include utilities.r
NULL
.all_aesthetics <- c("adj", "alpha", "angle", "bg", "cex", "col", "color",
"colour", "fg", "fill", "group", "hjust", "label", "linetype", "lower",
"lty", "lwd", "max", "middle", "min", "pch", "radius", "sample", "shape",
"size", "srt", "upper", "vjust", "weight", "width", "x", "xend", "xmax",
"xmin", "xintercept", "y", "yend", "ymax", "ymin", "yintercept", "z")
.base_to_ggplot <- c(
"col" = "colour",
"color" = "colour",
"pch" = "shape",
"cex" = "size",
"lty" = "linetype",
"lwd" = "size",
"srt" = "angle",
"adj" = "hjust",
"bg" = "fill",
"fg" = "colour",
"min" = "ymin",
"max" = "ymax"
)
#' 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
#' \code{\link{ggplot2}} and in individual layers.
#'
#' This function also standardise aesthetic names by performing partial
#' matching, converting color to colour, and translating old style R names to
#' ggplot names (eg. pch to shape, cex to size)
#'
#' @param x,y,... List of name value pairs giving aesthetics to map to
#' variables. The names for x and y aesthetics are typically omitted because
#' they are so common; all other aesthetics must be named.
#' @seealso See \code{\link{aes_}} for a version of \code{aes} that is
#' more suitable for programming with.
#' @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)
#'
#' # Aesthetic names are automatically standardised
#' aes(col = x)
#' aes(fg = x)
#' aes(color = x)
#' aes(colour = x)
#'
#' # aes is almost always used with ggplot() or a layer
#' ggplot(mpg, aes(displ, hwy)) + geom_point()
#' ggplot(mpg) + geom_point(aes(displ, hwy))
#'
#' # Aesthetics supplied to ggplot() are used as defaults for every layer
#' # you can override them, or supply different aesthetics for each layer
aes <- function(x, y, ...) {
aes <- structure(as.list(match.call()[-1]), class = "uneval")
rename_aes(aes)
}
#' @export
print.uneval <- function(x, ...) {
values <- vapply(x, deparse2, character(1))
bullets <- paste0("* ", format(names(x)), " -> ", values, "\n")
cat(bullets, sep = "")
}
#' @export
str.uneval <- function(object, ...) utils::str(unclass(object), ...)
#' @export
"[.uneval" <- function(x, i, ...) structure(unclass(x)[i], class = "uneval")
#' @export
as.character.uneval <- function(x, ...) {
char <- as.character(unclass(x))
names(char) <- names(x)
char
}
# Rename American or old-style aesthetics name
rename_aes <- function(x) {
# Convert prefixes to full names
full <- match(names(x), .all_aesthetics)
names(x)[!is.na(full)] <- .all_aesthetics[full[!is.na(full)]]
plyr::rename(x, .base_to_ggplot, warn_missing = FALSE)
}
# 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 programatically
#'
#' Aesthetic mappings describe how variables in the data are mapped to visual
#' properties (aesthetics) of geoms. \code{\link{aes}} uses non-standard
#' evaluation to capture the variable names. \code{aes_} and \code{aes_string}
#' require you to explicitly quote the inputs either with \code{""} for
#' \code{aes_string()}, or with \code{quote} or \code{~} for \code{aes_()}.
#' (\code{aes_q} is an alias to \code{aes_}). This makes \code{aes_} and
#' \code{aes_string} easy to program with.
#'
#' \code{aes_string} and \code{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
#' \code{\link{substitute}} to generate a call to \code{aes()}.
#'
#' I recommend using \code{aes_()}, because creating the equivalents of
#' \code{aes(colour = "my colour")} or \code{aes{x = `X$1`}}
#' with \code{aes_string()} is quite clunky.
#'
#' @param x,y,... List of name value pairs. Elements must be either
#' quoted calls, strings, one-sided formulas or constants.
#' @seealso \code{\link{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)
as_call <- function(x) {
if (is.formula(x) && length(x) == 2) {
x[[2]]
} else if (is.call(x) || is.name(x) || is.atomic(x)) {
x
} else {
stop("Aesthetic must be a one-sided formula, call, name, or constant.",
call. = FALSE)
}
}
mapping <- lapply(mapping, as_call)
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)
mapping <- lapply(mapping, function(x) {
if (is.character(x)) {
parse(text = x)[[1]]
} else {
x
}
})
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)
structure(
lapply(vars, as.name),
class = "uneval"
)
}
#' Automatic aesthetic mapping
#'
#' @param data data.frame or names of variables
#' @param ... aesthetics that need to be explicitly mapped.
#' @keywords internal
#' @export
aes_auto <- function(data = NULL, ...) {
warning("aes_auto() is deprecated", call. = FALSE)
# detect names of data
if (is.null(data)) {
stop("aes_auto requires data.frame or names of data.frame.")
} else if (is.data.frame(data)) {
vars <- names(data)
} else {
vars <- data
}
# automatically detected aes
vars <- intersect(.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")
}
ggplot2/R/scales-.rMemoryTime
# 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)
plyr::quickdf(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)
plyr::quickdf(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 <- plyr::tryapply(
aesthetics[new_aesthetics], eval,
envir = data, enclos = env
)
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/ggproto.rMemoryTime
#' Create a new ggproto object
#'
#' Construct a new object with \code{ggproto}, test with \code{is.proto},
#' and access parent methods/fields with \code{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 \code{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 \code{Adder}, which has a
#' method \code{addx = function(self, n) n + self$x}. Then, to call this
#' function, you would use \code{Adder$addx(10)} -- the \code{self} is passed
#' in automatically by the wrapper function. \code{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
#' \code{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 \code{NULL} (the default),
#' no class name will be added to the object.
#' @param _inherit ggproto object to inherit from. If \code{NULL}, don't
#' inherit from any object.
#' @param ... A list of members in the ggproto object.
#' @export
#' @examples
#' Adder <- ggproto("Adder",
#' x = 0,
#' add = function(self, n) {
#' self$x <- self$x + n
#' self$x
#' }
#' )
#' is.ggproto(Adder)
#'
#' Adder$add(10)
#' Adder$add(10)
#'
#' Doubler <- ggproto("Doubler", Adder,
#' add = function(self, n) {
#' ggproto_parent(Adder, self)$add(n * 2)
#' }
#' )
#' Doubler$x
#' Doubler$add(10)
ggproto <- function(`_class` = NULL, `_inherit` = NULL, ...) {
e <- new.env(parent = emptyenv())
members <- list(...)
if (length(members) != sum(nzchar(names(members)))) {
stop("All members of a ggproto object must be named.")
}
# R <3.1.2 will error when list2env() is given an empty list, so we need to
# check length. https://github.com/tidyverse/ggplot2/issues/1444
if (length(members) > 0) {
list2env(members, envir = e)
}
# Dynamically capture parent: this is necessary in order to avoid
# capturing the parent at package build time.
`_inherit` <- substitute(`_inherit`)
env <- parent.frame()
find_super <- function() {
eval(`_inherit`, env, NULL)
}
super <- find_super()
if (!is.null(super)) {
if (!is.ggproto(super)) {
stop("`_inherit` must be a ggproto object.")
}
e$super <- find_super
class(e) <- c(`_class`, class(super))
} else {
class(e) <- c(`_class`, "ggproto")
}
e
}
#' @export
#' @rdname ggproto
#' @param parent,self Access parent class \code{parent} of object \code{self}.
ggproto_parent <- function(parent, self) {
structure(list(parent = parent, self = self), class = "ggproto_parent")
}
#' @param x An object to test.
#' @export
#' @rdname ggproto
is.ggproto <- function(x) inherits(x, "ggproto")
fetch_ggproto <- function(x, name) {
res <- NULL
val <- .subset2(x, name)
# The is.null check is an optimization for a common case; exists() also
# catches the case where the value exists but has a NULL value.
if (!is.null(val) || exists(name, envir = x, inherits = FALSE)) {
res <- val
} else {
# If not found here, recurse into super environments
super <- .subset2(x, "super")
if (is.null(super)) {
# no super class
} else if (is.function(super)) {
res <- fetch_ggproto(super(), name)
} else {
stop(
class(x)[[1]], " was built with an incompatible version of ggproto.\n",
"Please reinstall the package that provides this extension.",
call. = FALSE
)
}
}
res
}
#' @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 \code{super} member.
#'
#' @param x A ggproto object to convert to a list.
#' @param inherit If \code{TRUE} (the default), flatten all inherited items into
#' the returned list. If \code{FALSE}, do not include any inherited items.
#' @param ... Further arguments to pass to \code{as.list.environment}.
#' @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 \code{$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 \code{TRUE} (the default), show a flattened list of all local
#' and inherited members. If \code{FALSE}, show the inheritance hierarchy.
#' @param ... If the ggproto object has a \code{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/plot-build.rMemoryTime
#' Build ggplot for rendering.
#'
#' \code{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.
#'
#' \code{layer_data}, \code{layer_grob}, and \code{layer_scales} are helper
#' functions that returns the data, grob, or scales associated with a given
#' layer. These are useful for tests.
#'
#' @param plot ggplot object
#' @seealso \code{\link{print.ggplot}} and \code{\link{benchplot}} for
#' functions that contain the complete set of steps for generating
#' a ggplot2 plot.
#' @keywords internal
#' @export
ggplot_build <- function(plot) {
plot <- plot_clone(plot)
if (length(plot$layers) == 0) {
plot <- plot + geom_blank()
}
layers <- plot$layers
layer_data <- lapply(layers, function(y) y$layer_data(plot$data))
scales <- plot$scales
# Apply function to layer and matching data
by_layer <- function(f) {
out <- vector("list", length(data))
for (i in seq_along(data)) {
out[[i]] <- f(l = layers[[i]], d = data[[i]])
}
out
}
# Initialise panels, add extra data for margins & missing facetting
# variables, and add on a PANEL variable to data
layout <- create_layout(plot$facet)
data <- layout$setup(layer_data, plot$data, plot$plot_env, plot$coordinates)
data <- layout$map(data)
# 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's
# displayed, or does it include the range of underlying data
layout$reset_scales()
layout$train_position(data, scale_x(), scale_y())
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)
}
# Train coordinate system
layout$train_ranges(plot$coordinates)
# 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)
list(data = data, layout = layout, plot = plot)
}
#' @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$panel_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, b$plot$coordinates)
}
#' 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 \code{\link{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 \code{\link{print.ggplot}} and \code{link{benchplot}} for
#' for functions that contain the complete set of steps for generating
#' a ggplot2 plot.
#' @return a \code{\link{gtable}} object
#' @keywords internal
#' @param plot plot object
#' @param data plot data generated by \code{\link{ggplot_build}}
#' @export
ggplot_gtable <- 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$coordinates),
plot$layers, data)
plot_table <- layout$render(geom_grobs, data, plot$coordinates, theme, plot$labels)
# Legends
position <- theme$legend.position
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, expand_y = TRUE)
title_height <- grobHeight(title)
# Subtitle
subtitle <- element_render(theme, "plot.subtitle", plot$labels$subtitle, expand_y = TRUE)
subtitle_height <- grobHeight(subtitle)
# whole plot annotation
caption <- element_render(theme, "plot.caption", plot$labels$caption, expand_y = TRUE)
caption_height <- grobHeight(caption)
pans <- plot_table$layout[grepl("^panel", plot_table$layout$name), ,
drop = FALSE]
plot_table <- gtable_add_rows(plot_table, subtitle_height, pos = 0)
plot_table <- gtable_add_grob(plot_table, subtitle, name = "subtitle",
t = 1, b = 1, l = min(pans$l), r = max(pans$r), clip = "off")
plot_table <- gtable_add_rows(plot_table, title_height, pos = 0)
plot_table <- gtable_add_grob(plot_table, title, name = "title",
t = 1, b = 1, l = min(pans$l), r = max(pans$r), clip = "off")
plot_table <- gtable_add_rows(plot_table, caption_height, pos = -1)
plot_table <- gtable_add_grob(plot_table, caption, name = "caption",
t = -1, b = -1, l = min(pans$l), r = max(pans$r), clip = "off")
# Margins
plot_table <- gtable_add_rows(plot_table, theme$plot.margin[1], pos = 0)
plot_table <- gtable_add_cols(plot_table, theme$plot.margin[2])
plot_table <- gtable_add_rows(plot_table, theme$plot.margin[3])
plot_table <- gtable_add_cols(plot_table, theme$plot.margin[4], pos = 0)
if (inherits(theme$plot.background, "element")) {
plot_table <- gtable_add_grob(plot_table,
element_render(theme, "plot.background"),
t = 1, l = 1, b = -1, r = -1, name = "background", z = -Inf)
plot_table$layout <- plot_table$layout[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1)),]
plot_table$grobs <- plot_table$grobs[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1))]
}
plot_table
}
#' Generate a ggplot2 plot grob.
#'
#' @param x ggplot2 object
#' @keywords internal
#' @export
ggplotGrob <- function(x) {
ggplot_gtable(ggplot_build(x))
}
ggplot2/R/scale-continuous.rMemoryTime
#' Position scales for continuous data (x & y)
#'
#' \code{scale_x_continuous} and \code{scale_y_continuous} are the default
#' scales for continuous x and y aesthetics. There are three variants
#' that set the \code{trans} argument for commonly used transformations:
#' \code{scale_*_log10}, \code{scale_*_sqrt} and \code{scale_*_reverse}.
#'
#' For simple manipulation of labels and limits, you may wish to use
#' \code{\link{labs}()} and \code{\link{lims}()} instead.
#'
#' @inheritParams continuous_scale
#' @family position scales
#' @param ... Other arguments passed on to \code{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))
#'
#' # * add what labels they have
#' 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 specifify a secondary axis
#'
#' @seealso \code{\link{sec_axis}} for how to specify secondary axes
#' @export
scale_x_continuous <- function(name = waiver(), breaks = waiver(),
minor_breaks = waiver(), labels = waiver(),
limits = NULL, expand = waiver(), oob = censor,
na.value = NA_real_, trans = "identity",
position = "bottom", sec.axis = waiver()) {
sc <- continuous_scale(
c("x", "xmin", "xmax", "xend", "xintercept", "xmin_final", "xmax_final", "xlower", "xmiddle", "xupper"),
"position_c", identity, name = name, breaks = breaks,
minor_breaks = minor_breaks, labels = labels, limits = limits,
expand = expand, oob = oob, na.value = na.value, trans = trans,
guide = "none", position = position, super = ScaleContinuousPosition
)
if (!is.waive(sec.axis)) {
if (is.formula(sec.axis)) sec.axis <- sec_axis(sec.axis)
if (!is.sec_axis(sec.axis)) stop("Secondary axes must be specified using 'sec_axis()'")
sc$secondary.axis <- sec.axis
}
sc
}
#' @rdname scale_continuous
#' @export
scale_y_continuous <- function(name = waiver(), breaks = waiver(),
minor_breaks = waiver(), labels = waiver(),
limits = NULL, expand = waiver(), oob = censor,
na.value = NA_real_, trans = "identity",
position = "left", sec.axis = waiver()) {
sc <- continuous_scale(
c("y", "ymin", "ymax", "yend", "yintercept", "ymin_final", "ymax_final", "lower", "middle", "upper"),
"position_c", identity, name = name, breaks = breaks,
minor_breaks = minor_breaks, labels = labels, limits = limits,
expand = expand, oob = oob, na.value = na.value, trans = trans,
guide = "none", position = position, super = ScaleContinuousPosition
)
if (!is.waive(sec.axis)) {
if (is.formula(sec.axis)) sec.axis <- sec_axis(sec.axis)
if (!is.sec_axis(sec.axis)) stop("Secondary axes must be specified using 'sec_axis()'")
sc$secondary.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-.rMemoryTime
#' @section Scales:
#'
#' All \code{scale_*} functions (like \code{scale_x_continuous}) return a
#' \code{Scale*} object (like \code{ScaleContinuous}). The \code{Scale*}
#' object represents a single scale.
#'
#' Each of the \code{Scale*} objects is a \code{\link{ggproto}} object,
#' descended from the top-level \code{Scale}.
#'
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
Scale <- ggproto("Scale", NULL,
call = NULL,
aesthetics = aes(),
scale_name = NULL,
palette = function() {
stop("Not implemented", call. = FALSE)
},
range = ggproto(NULL, Range),
limits = NULL,
na.value = NA,
expand = waiver(),
name = waiver(),
breaks = waiver(),
labels = waiver(),
guide = "legend",
position = "left",
is_discrete = function() {
stop("Not implemented", call. = FALSE)
},
# Train scale from a data frame.
#
# @return updated range (invisibly)
# @seealso \code{\link{scale_train}} for scale specific generic method
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 an individual scale from a vector of data.
train = function(self, x) {
stop("Not implemented", call. = FALSE)
},
# Reset scale, untraining ranges
reset = function(self) {
self$range$reset()
},
is_empty = function(self) {
is.null(self$range$range) && is.null(self$limits)
},
# @return list of transformed variables
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) {
stop("Not implemented", call. = FALSE)
},
# @return list of mapped variables
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]))
}
},
# @kohske
# map tentatively accept limits argument.
# map replaces oob (i.e., outside limits) values with NA.
#
# Previously limits are always scale_limits(scale).
# But if this function is called to get breaks,
# and breaks spans oob, the oob breaks is replaces by NA.
# This makes impossible to display oob breaks.
# Now coord_train calls this function with limits determined by coord (with expansion).
map = function(self, x, limits = self$get_limits()) {
stop("Not implemented", call. = FALSE)
},
# if scale contains a NULL, use the default scale range
# if scale contains a NA, use the default range for that axis, otherwise
# use the user defined limit for that axis
get_limits = function(self) {
if (self$is_empty()) return(c(0, 1))
if (!is.null(self$limits)) {
ifelse(!is.na(self$limits), self$limits, self$range$range)
} else {
self$range$range
}
},
# The physical size of the scale.
# This always returns a numeric vector of length 2, giving the physical
# dimensions of a scale.
dimension = function(self, expand = c(0, 0)) {
stop("Not implemented", call. = FALSE)
},
get_breaks = function(self, limits = self$get_limits()) {
stop("Not implemented", call. = FALSE)
},
# The numeric position of scale breaks, used by coord/guide
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()) {
stop("Not implemented", call. = FALSE)
},
get_labels = function(self, breaks = self$get_breaks()) {
stop("Not implemented", call. = FALSE)
},
# Each implementation of a Scale must implement a clone method that makes
# copies of reference objecsts.
clone = function(self) {
stop("Not implemented", call. = FALSE)
},
break_info = function(self, range = NULL) {
stop("Not implemented", call. = FALSE)
},
# Only relevant for positional scales
axis_order = function(self) {
ord <- c("primary", "secondary")
if (self$position %in% c("right", "bottom")) {
ord <- rev(ord)
}
ord
},
# Here to make it possible for scales to modify the default titles
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) {
stop("`breaks` and `labels` must have the same length", call. = FALSE)
}
TRUE
}
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
ScaleContinuous <- ggproto("ScaleContinuous", Scale,
range = continuous_range(),
na.value = NA_real_,
rescaler = rescale, # Used by diverging and n colour gradients x
oob = censor,
minor_breaks = waiver(),
is_discrete = function() FALSE,
train = function(self, x) {
if (length(x) == 0) return()
self$range$train(x)
},
transform = function(self, x) {
new_x <- self$trans$transform(x)
if (any(is.finite(x) != is.finite(new_x))) {
type <- if (self$scale_name == "position_c") "continuous" else "discrete"
axis <- if ("x" %in% self$aesthetics) "x" else "y"
warning("Transformation introduced infinite values in ", type, " ", axis, "-axis", call. = FALSE)
}
new_x
},
map = function(self, x, limits = self$get_limits()) {
x <- self$oob(self$rescaler(x, from = limits))
uniq <- unique(x)
pal <- self$palette(uniq)
scaled <- pal[match(x, uniq)]
ifelse(!is.na(scaled), scaled, self$na.value)
},
dimension = function(self, expand = c(0, 0)) {
expand_range(self$get_limits(), expand[1], expand[2])
},
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)
} else if (identical(self$breaks, NA)) {
stop("Invalid breaks specification. Use NULL, not NA")
} else if (zero_range(as.numeric(limits))) {
breaks <- limits[1]
} else if (is.waive(self$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
# And any breaks outside the dimensions need to be flagged as missing
#
# @kohske
# TODO: replace NA with something else for flag.
# guides cannot discriminate oob from missing value.
breaks <- censor(self$trans$transform(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)
} else if (identical(self$minor_breaks, NA)) {
stop("Invalid minor_breaks specification. Use NULL, not NA", call. = FALSE)
} else if (is.waive(self$minor_breaks)) {
if (is.null(b)) {
breaks <- NULL
} else {
b <- b[!is.na(b)]
if (length(b) < 2) return()
bd <- diff(b)[1]
if (min(limits) < min(b)) b <- c(b[1] - bd, b)
if (max(limits) > max(b)) b <- c(b, b[length(b)] + bd)
breaks <- unique(unlist(mapply(seq, b[-length(b)], b[-1], length.out = n + 1,
SIMPLIFY = FALSE)))
}
} 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)
} else if (identical(self$labels, NA)) {
stop("Invalid labels specification. Use NULL, not NA", call. = FALSE)
} 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)) {
stop("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)
# 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 = "")
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)) warning("Cached palette does not match requested", call. = FALSE)
pal <- self$palette(n)
self$palette.cache <- pal
self$n.breaks.cache <- n
}
if (is.null(names(pal))) {
pal_match <- pal[match(as.character(x), limits)]
} else {
pal_match <- pal[match(as.character(x), names(pal))]
pal_match <- unname(pal_match)
}
if (self$na.translate) {
ifelse(is.na(x) | is.na(pal_match), self$na.value, pal_match)
} else {
pal_match
}
},
dimension = function(self, expand = c(0, 0)) {
expand_range(length(self$get_limits()), expand[1], expand[2])
},
get_breaks = function(self, limits = self$get_limits()) {
if (self$is_empty()) return(numeric())
if (is.null(self$breaks)) {
return(NULL)
} else if (identical(self$breaks, NA)) {
stop("Invalid breaks specification. Use NULL, not NA", call. = FALSE)
} else if (is.waive(self$breaks)) {
breaks <- limits
} else if (is.function(self$breaks)) {
breaks <- self$breaks(limits)
} else {
breaks <- self$breaks
}
# Breaks can only occur only on values in domain
in_domain <- intersect(breaks, self$get_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)
} else if (identical(self$labels, NA)) {
stop("Invalid labels specification. Use NULL, not NA", call. = FALSE)
} else if (is.waive(self$labels)) {
breaks <- self$get_breaks()
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)
}
)
#' Continuous scale constructor.
#'
#' @export
#' @inheritParams discrete_scale
#' @param name The name of the scale. Used as axis or legend title. If
#' \code{NULL}, the default, the name of the scale is taken from the first
#' mapping used for that aesthetic.
#' @param breaks One of: \itemize{
#' \item \code{NULL} for no breaks
#' \item \code{waiver()} for the default breaks computed by the
#' transformation object
#' \item A numeric vector of positions
#' \item A function that takes the limits as input and returns breaks
#' as output
#' }
#' @param minor_breaks One of: \itemize{
#' \item \code{NULL} for no minor breaks
#' \item \code{waiver()} for the default breaks (one minor break between
#' each major break)
#' \item A numeric vector of positions
#' \item A function that given the limits returns a vector of minor breaks.
#' }
#' @param labels One of: \itemize{
#' \item \code{NULL} for no labels
#' \item \code{waiver()} for the default labels computed by the
#' transformation object
#' \item A character vector giving labels (must be same length as \code{breaks})
#' \item A function that takes the breaks as input and returns labels
#' as output
#' }
#' @param limits A numeric vector of length two providing limits of the scale.
#' Use \code{NA} to refer to the existing minimum or maximum.
#' @param rescaler Used by diverging and n colour gradients
#' (i.e. \code{\link{scale_colour_gradient2}}, \code{\link{scale_colour_gradientn}}).
#' A function used to scale the input values to the range [0, 1].
#' @param oob Function that handles limits outside of the scale limits
#' (out of bounds). The default replaces out of bounds values with NA.
#' @param na.value Missing values will be replaced with this value.
#' @param trans Either the name of a transformation object, or the
#' object itself. Built-in transformations include "asn", "atanh",
#' "boxcox", "exp", "identity", "log", "log10", "log1p", "log2",
#' "logit", "probability", "probit", "reciprocal", "reverse" and "sqrt".
#'
#' A transformation object bundles together a transform, it's inverse,
#' and methods for generating breaks and labels. Transformation objects
#' are defined in the scales package, and are called \code{name_trans}, e.g.
#' \code{\link[scales]{boxcox_trans}}. You can create your own
#' transformation with \code{\link[scales]{trans_new}}.
#' @param expand A numeric vector of length two giving multiplicative and
#' additive expansion constants. These constants ensure that the data is
#' placed some distance away from the axes. The defaults are
#' \code{c(0.05, 0)} for continuous variables, and \code{c(0, 0.6)} for
#' discrete variables.
#' @param guide Name of guide object, or object itself.
#' @param position The position of the axis. "left" or "right" for vertical
#' scales, "top" or "bottom" for horizontal scales
#' @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(), labels = waiver(), limits = NULL,
rescaler = rescale, oob = censor, expand = waiver(), na.value = NA_real_,
trans = "identity", guide = "legend", position = "left", super = ScaleContinuous) {
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, # Used by diverging and n colour gradients
oob = oob,
name = name,
breaks = breaks,
minor_breaks = minor_breaks,
labels = labels,
guide = guide,
position = position
)
}
#' Discrete scale constructor.
#'
#' @export
#' @param aesthetics the names of the aesthetics that this scale works with
#' @param scale_name the name of the 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
#' @param name the name of the scale - used as the axis label or the legend
#' title
#' @param drop Should unused factor levels be omitted from the scale?
#' The default, \code{TRUE}, uses the levels that appear in the data;
#' \code{FALSE} uses all the levels in the factor.
#' @param breaks control the breaks in the guide. There are four possible
#' types of input:
#' \itemize{
#' \item \code{NULL}: don't display any breaks
#' \item a character vector giving the breaks as they should appear on the
#' axis or in the legend.
#' \item \code{waiver()} to use the default break computation.
#' \item a function, that when called with a single argument, a character
#' vector giving the limits of the scale, returns a character vector
#' specifying which breaks to display.
#' }
#' This parameter does not affect in any way how the data is scaled - it
#' only affects the appearance of the legend.
#' @param limits A character vector specifying the data range for the scale.
# The limits control what levels are displayed in the plot, their order,
#' and the default order of their display in guides.
#' @param labels \code{NULL} for no labels, \code{waiver()} for default
#' labels (labels the same as breaks), a character vector the same length
#' as breaks, or a named character vector whose names are used to match
#' replacement the labels for matching breaks.
#' @param expand a numeric vector of length two, giving a multiplicative and
#' additive constant used to expand the range of the scales so that there
#' is a small gap between the data and the axes. The defaults are (0,0.6)
#' for discrete scales and (0.05,0) for continuous scales.
#' @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 \code{na.translate = FALSE}.
#' @param na.value If \code{na.translate = TRUE}, what value aesthetic
#' value should missing be displayed as? Does not apply to position scales
#' where \code{NA} is always placed at the far right.
#' @param guide the name of, or actual function, used to create the
#' guide. See \code{\link{guides}} for more info.
#' @param position The position of the axis. "left" or "right" for vertical
#' scales, "top" or "bottom" for horizontal scales
#' @param super The super class to use for the constructed scale
#' @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) {
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"
}
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
)
}
ggplot2/R/facet-.rMemoryTime
#' @include ggproto.r
NULL
#' @section Facets:
#'
#' All \code{facet_*} functions returns a \code{Facet} object or an object of a
#' \code{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 \code{\link{gtable}} manipulation.
#' For some examples of both, please see the extension vignette.
#'
#' \code{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:
#'
#' \itemize{
#' \item \code{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 \code{PANEL}, \code{SCALE_X}, and \code{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.
#'
#' \item \code{map_data}: This method is supplied the data for each layer in
#' turn and is expected to supply a \code{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
#' \code{facet_grid}.
#'
#' \item \code{draw_panels}: This is where the panels are assembled into a
#' \code{gtable} object. The method recieves, 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:
#'
#' \itemize{
#' \item \code{setup_params}:
#' \item \code{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.
#'
#' \item \code{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.
#'
#' \item \code{finish_data}: Make last-minute modifications to layer data
#' before it is rendered by the Geoms. The default is to not modify it.
#'
#' \item \code{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.
#'
#' \item \code{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.
#'
#' \item \code{draw_labels}: Given the gtable returned by \code{draw_panels},
#' add axis titles to the gtable. The default is to add one title at each side
#' depending on the position and existance of axes.
#' }
#'
#' All extension methods recieve 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 \code{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(),
# Layout interface --------------------------------------------------------
train = function(self, data) {
self$compute_layout(data, self$params)
},
map = function(self, data, layout) {
self$map_data(data, layout, self$params)
},
render_back = function(self, data, layout, x_scales, y_scales, theme) {
self$draw_back(data, layout, x_scales, y_scales, theme, self$params)
},
render_front = function(self, data, layout, x_scales, y_scales, theme) {
self$draw_front(data, layout, x_scales, y_scales, theme, self$params)
},
render_panels = function(self, panels, layout, x_scales, y_scales, ranges, coord, data, theme, labels) {
panels <- self$draw_panels(panels, layout, x_scales, y_scales, ranges, coord, data, theme, self$params)
self$draw_labels(panels, layout, x_scales, y_scales, ranges, coord, data, theme, labels, self$params)
},
train_positions = function(self, x_scales, y_scales, layout, data) {
self$train_scales(x_scales, y_scales, layout, data, self$params)
},
# Extension interface -----------------------------------------------------
compute_layout = function(data, params) {
stop("Not implemented", call. = FALSE)
},
map_data = function(data, layout, params) {
stop("Not implemented", call. = FALSE)
},
init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) {
scales <- list()
if (!is.null(x_scale)) {
scales$x <- plyr::rlply(max(layout$SCALE_X), x_scale$clone())
}
if (!is.null(y_scale)) {
scales$y <- plyr::rlply(max(layout$SCALE_Y), y_scale$clone())
}
scales
},
train_scales = function(x_scales, y_scales, layout, data, params) {
# loop over each layer, training x and y scales in turn
for (layer_data in data) {
match_id <- match(layer_data$PANEL, layout$PANEL)
if (!is.null(x_scales)) {
x_vars <- intersect(x_scales[[1]]$aesthetics, names(layer_data))
SCALE_X <- layout$SCALE_X[match_id]
scale_apply(layer_data, x_vars, "train", SCALE_X, x_scales)
}
if (!is.null(y_scales)) {
y_vars <- intersect(y_scales[[1]]$aesthetics, names(layer_data))
SCALE_Y <- layout$SCALE_Y[match_id]
scale_apply(layer_data, y_vars, "train", SCALE_Y, y_scales)
}
}
},
draw_back = function(data, layout, x_scales, y_scales, theme, params) {
rep(list(zeroGrob()), length(unique(layout$PANEL)))
},
draw_front = function(data, layout, x_scales, y_scales, theme, params) {
rep(list(zeroGrob()), length(unique(layout$PANEL)))
},
draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) {
stop("Not implemented", call. = FALSE)
},
draw_labels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, labels, params) {
panel_dim <- find_panel(panels)
xlab_height_top <- grobHeight(labels$x[[1]])
panels <- gtable_add_rows(panels, xlab_height_top, pos = 0)
panels <- gtable_add_grob(panels, labels$x[[1]], name = "xlab-t",
l = panel_dim$l, r = panel_dim$r, t = 1, clip = "off")
xlab_height_bottom <- grobHeight(labels$x[[2]])
panels <- gtable_add_rows(panels, xlab_height_bottom, pos = -1)
panels <- gtable_add_grob(panels, labels$x[[2]], name = "xlab-b",
l = panel_dim$l, r = panel_dim$r, t = -1, clip = "off")
panel_dim <- find_panel(panels)
ylab_width_left <- grobWidth(labels$y[[1]])
panels <- gtable_add_cols(panels, ylab_width_left, pos = 0)
panels <- gtable_add_grob(panels, labels$y[[1]], name = "ylab-l",
l = 1, b = panel_dim$b, t = panel_dim$t, clip = "off")
ylab_width_right <- grobWidth(labels$y[[2]])
panels <- gtable_add_cols(panels, ylab_width_right, pos = -1)
panels <- gtable_add_grob(panels, labels$y[[2]], name = "ylab-r",
l = -1, b = panel_dim$b, t = panel_dim$t, clip = "off")
panels
},
setup_params = function(data, params) {
params
},
setup_data = function(data, params) {
data
},
finish_data = function(data, layout, x_scales, y_scales, params) {
data
}
)
# Helpers -----------------------------------------------------------------
#' Is this object a facetting specification?
#'
#' @param x object to test
#' @keywords internal
#' @export
is.facet <- function(x) inherits(x, "Facet")
# A "special" value, currently not used but could be used to determine
# if faceting is active
NO_PANEL <- -1L
unique_combs <- function(df) {
if (length(df) == 0) return()
unique_values <- plyr::llply(df, ulevels)
rev(expand.grid(rev(unique_values), stringsAsFactors = FALSE,
KEEP.OUT.ATTRS = TRUE))
}
df.grid <- function(a, b) {
if (is.null(a) || nrow(a) == 0) return(b)
if (is.null(b) || nrow(b) == 0) return(a)
indexes <- expand.grid(
i_a = seq_len(nrow(a)),
i_b = seq_len(nrow(b))
)
plyr::unrowname(cbind(
a[indexes$i_a, , drop = FALSE],
b[indexes$i_b, , drop = FALSE]
))
}
# 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 facetting by an expression,
# but that seems like a reasonable tradeoff.
eval_facet_vars <- function(vars, data, env = emptyenv()) {
nms <- names(vars)
out <- list()
for (i in seq_along(vars)) {
out[[ nms[[i]] ]] <- eval_facet_var(vars[[i]], data, env = env)
}
tibble::as_tibble(out)
}
eval_facet_var <- function(var, data, env = emptyenv()) {
if (is.name(var)) {
var <- as.character(var)
if (var %in% names(data)) {
data[[var]]
} else {
NULL
}
} else if (is.call(var)) {
eval(var, envir = data, enclos = env)
} else {
stop("Must use either variable name or expression when facetting",
call. = FALSE)
}
}
layout_null <- function() {
data.frame(PANEL = 1, ROW = 1, COL = 1, SCALE_X = 1, SCALE_Y = 1)
}
#' Get the maximal width/length of a list of grobs
#'
#' @param grobs A list of grobs
#'
#' @return The largest value. measured in cm as a unit object
#'
#' @keywords internal
#' @export
max_height <- function(grobs) {
unit(max(unlist(lapply(grobs, height_cm))), "cm")
}
#' @rdname max_height
#' @export
max_width <- function(grobs) {
unit(max(unlist(lapply(grobs, width_cm))), "cm")
}
#' Find panels in a gtable
#'
#' These functions help detect the placement of panels in a gtable, if they are
#' named with "panel" in the beginning. \code{find_panel} returns the extend of
#' the panel area, while \code{panel_cols} and \code{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]
data.frame(
t = min(panels$t),
r = max(panels$r),
b = max(panels$b),
l = min(panels$l)
)
}
#' @rdname find_panel
#' @export
panel_cols = function(table) {
panels <- table$layout[grepl("^panel", table$layout$name), , drop = FALSE]
unique(panels[, c('l', 'r')])
}
#' @rdname find_panel
#' @export
panel_rows <- function(table) {
panels <- table$layout[grepl("^panel", table$layout$name), , drop = FALSE]
unique(panels[, c('t', 'b')])
}
#' Take input data and define a mapping between facetting 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 facetting vars
#'
#' @keywords internal
#' @export
combine_vars <- function(data, env = emptyenv(), vars = NULL, drop = TRUE) {
if (length(vars) == 0) return(data.frame())
# For each layer, compute the facet values
values <- compact(plyr::llply(data, eval_facet_vars, vars = vars, env = env))
# Form the base data frame which contains all combinations of facetting
# variables that appear in the data
has_all <- unlist(plyr::llply(values, length)) == length(vars)
if (!any(has_all)) {
stop("At least one layer must contain all variables used for facetting")
}
base <- unique(plyr::ldply(values[has_all]))
if (!drop) {
base <- unique_combs(base)
}
# Systematically add on missing combinations
for (value in values[!has_all]) {
if (empty(value)) next;
old <- base[setdiff(names(base), names(value))]
new <- unique(value[intersect(names(base), names(value))])
if (drop) {
new <- unique_combs(new)
}
base <- rbind(base, df.grid(old, new))
}
if (empty(base)) {
stop("Faceting variables must have at least one value", call. = FALSE)
}
base
}
#' Render panel axes
#'
#' These helpers facilitates generating theme compliant axes when
#' building up the plot.
#'
#' @param x,y A list of ranges as available to the draw_panel method in
#' \code{Facet} subclasses.
#' @param coord A \code{Coord} object
#' @param theme A \code{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 \code{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 \code{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/layout.RMemoryTime
create_layout <- function(facet) {
ggproto(NULL, Layout, facet = facet)
}
Layout <- ggproto("Layout", NULL,
facet = NULL,
panel_layout = NULL,
panel_scales = NULL,
panel_ranges = NULL,
setup = function(self, data, plot_data, plot_env, plot_coord) {
data <- c(list(plot_data), data)
self$facet$params <- utils::modifyList(
self$facet$setup_params(data, self$facet$params),
list(plot_env = plot_env)
)
data <- self$facet$setup_data(data, self$facet$params)
self$panel_layout <- self$facet$train(data)
if (!all(c("PANEL", "SCALE_X", "SCALE_Y") %in% names(self$panel_layout))) {
stop("Facet layout has bad format. It must contains the columns 'PANEL', 'SCALE_X', and 'SCALE_Y'", call. = FALSE)
}
# Special case of CoordFlip - switch the layout scales
if (inherits(plot_coord, "CoordFlip")) {
self$panel_layout[, c("SCALE_X", "SCALE_Y")] <- self$panel_layout[, c("SCALE_Y", "SCALE_X"), drop = FALSE]
}
data[-1]
},
map = function(self, data) {
lapply(data, function(data) {
self$facet$map(data, self$panel_layout)
})
},
render = function(self, panels, data, coord, theme, labels) {
below <- self$facet$render_back(data, self$panel_layout, self$panel_scales$x, self$panel_scales$y, theme)
above <- self$facet$render_front(data, self$panel_layout, self$panel_scales$x, self$panel_scales$y, theme)
panels <- lapply(seq_along(panels[[1]]), function(i) {
fg <- coord$render_fg(self$panel_ranges[[i]], theme)
bg <- coord$render_bg(self$panel_ranges[[i]], theme)
panel <- lapply(panels, `[[`, i)
panel <- c(below[i], panel, above[i])
if (theme$panel.ontop) {
panel <- c(panel, list(bg), list(fg))
} else {
panel <- c(list(bg), panel, list(fg))
}
ggname(paste("panel", i, sep = "-"),
gTree(children = do.call("gList", panel)))
})
labels <- coord$labels(list(
x = self$xlabel(labels),
y = self$ylabel(labels)
))
labels <- self$render_labels(labels, theme)
self$facet$render_panels(panels, self$panel_layout, self$panel_scales$x,
self$panel_scales$y, self$panel_ranges, coord, data, theme, labels)
},
train_position = function(self, data, x_scale, y_scale) {
# Initialise scales if needed, and possible.
layout <- self$panel_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_positions(self$panel_scales$x, self$panel_scales$y, layout, 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()
},
map_position = function(self, data) {
layout <- self$panel_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
})
},
finish_data = function(self, data) {
lapply(data, function(layer_data) {
self$facet$finish_data(layer_data, self$panel_layout, self$panel_scales$x,
self$panel_scales$y, self$facet$params)
})
},
get_scales = function(self, i) {
this_panel <- self$panel_layout[self$panel_layout$PANEL == i, ]
list(
x = self$panel_scales$x[[this_panel$SCALE_X]],
y = self$panel_scales$y[[this_panel$SCALE_Y]]
)
},
train_ranges = function(self, coord) {
compute_range <- function(ix, iy) {
# TODO: change coord_train method to take individual x and y scales
coord$train(list(x = self$panel_scales$x[[ix]], y = self$panel_scales$y[[iy]]))
}
# Switch position of all scales if CoordFlip
if (inherits(coord, "CoordFlip") || (inherits(coord, "CoordPolar") && coord$theta == "y")) {
lapply(self$panel_scales$x, function(scale) {
scale$position <- if (scale$position == "top") "bottom" else "top"
})
lapply(self$panel_scales$y, function(scale) {
scale$position <- if (scale$position == "left") "right" else "left"
})
}
self$panel_ranges <- Map(compute_range, self$panel_layout$SCALE_X, self$panel_layout$SCALE_Y)
},
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 == 2 && label == "y") ".right" else if (i == 1 && label == "x") ".top" else ""
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]],
expand_x = label == "y",
expand_y = label == "x"
)
})
})
names(label_grobs) <- names(labels)
label_grobs
}
)
# Helpers -----------------------------------------------------------------
# Function for applying scale method to multiple variables in a given
# data set. Implement in such a way to minimize copying and hence maximise
# speed
scale_apply <- function(data, vars, method, scale_id, scales) {
if (length(vars) == 0) return()
if (nrow(data) == 0) return()
n <- length(scales)
if (any(is.na(scale_id))) stop()
scale_index <- plyr::split_indices(scale_id, n)
lapply(vars, function(var) {
pieces <- lapply(seq_along(scales), function(i) {
scales[[i]][[method]](data[[var]][scale_index[[i]]])
})
# Join pieces back together, if necessary
if (!is.null(pieces)) {
unlist(pieces)[order(unlist(scale_index))]
}
})
}
ggplot2/R/range.rMemoryTime
#' Mutable ranges have a two methods (\code{train} and \code{reset}), and make
#' it possible to build up complete ranges with multiple passes.
#'
#' These range objects should be instantiated with
#' \code{\link{continuous_range}} and \code{\link{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/coord-cartesian-.rMemoryTime
#' 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 \code{TRUE}, the default, adds a small expansion factor to
#' the limits to ensure that data and axes don't overlap. If \code{FALSE},
#' limits are taken exactly from the data or \code{xlim}/\code{ylim}.
#' @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) {
ggproto(NULL, CoordCartesian,
limits = list(x = xlim, y = ylim),
expand = expand
)
}
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
CoordCartesian <- ggproto("CoordCartesian", Coord,
is_linear = function() TRUE,
distance = function(x, y, scale_details) {
max_dist <- dist_euclidean(scale_details$x.range, scale_details$y.range)
dist_euclidean(x, y) / max_dist
},
transform = function(data, scale_details) {
rescale_x <- function(data) rescale(data, from = scale_details$x.range)
rescale_y <- function(data) rescale(data, from = scale_details$y.range)
data <- transform_position(data, rescale_x, rescale_y)
transform_position(data, squish_infinite, squish_infinite)
},
train = function(self, scale_details) {
train_cartesian <- function(scale_details, limits, name) {
if (self$expand) {
expand <- expand_default(scale_details)
} else {
expand <- c(0, 0)
}
if (is.null(limits)) {
range <- scale_details$dimension(expand)
} else {
range <- range(scale_details$transform(limits))
range <- expand_range(range, expand[1], expand[2])
}
out <- scale_details$break_info(range)
out$arrange <- scale_details$axis_order()
names(out) <- paste(name, names(out), sep = ".")
out
}
c(
train_cartesian(scale_details$x, self$limits$x, "x"),
train_cartesian(scale_details$y, self$limits$y, "y")
)
}
)
ggplot2/R/utilities.rMemoryTime
#' @export
#' @examples
#' ggplot(mpg, aes(displ, hwy)) +
#' geom_point(alpha = 0.5, colour = "blue")
#'
#' ggplot(mpg, aes(displ, hwy)) +
#' geom_point(colour = alpha("blue", 0.5))
scales::alpha
"%||%" <- function(a, b) {
if (!is.null(a)) a else b
}
"%|W|%" <- function(a, b) {
if (!is.waive(a)) a else b
}
# Check required aesthetics are present
# This is used by geoms and stats to give a more helpful error message
# when required aesthetics are missing.
#
# @param character vector of required aesthetics
# @param character vector of present aesthetics
# @param name of object for error message
# @keyword internal
check_required_aesthetics <- function(required, present, name) {
missing_aes <- setdiff(required, present)
if (length(missing_aes) == 0) return()
stop(name, " requires the following missing aesthetics: ",
paste(missing_aes, collapse = ", "), call. = FALSE)
}
# Concatenate a named list for output
# Print a \code{list(a=1, b=2)} as \code{(a=1, b=2)}
#
# @param list to concatenate
# @keyword internal
#X clist(list(a=1, b=2))
#X clist(par()[1:5])
clist <- function(l) {
paste(paste(names(l), l, sep = " = ", collapse = ", "), sep = "")
}
try_require <- function(package, fun) {
if (requireNamespace(package, quietly = TRUE)) {
library(package, character.only = TRUE)
return(invisible())
}
stop("Package `", package, "` required for `", fun , "`.\n",
"Please install and try again.", call. = FALSE)
}
# Return unique columns
# This is used for figuring out which columns are constant within a group
#
# @keyword internal
uniquecols <- function(df) {
df <- df[1, sapply(df, function(x) length(unique(x)) == 1), drop = FALSE]
rownames(df) <- 1:nrow(df)
df
}
#' Convenience function to remove missing values from a data.frame
#'
#' Remove all non-complete rows, with a warning if \code{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 \code{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 \code{TRUE}, will also remove non-finite values.
#' @keywords internal
#' @export
remove_missing <- function(df, na.rm = FALSE, vars = names(df), name = "",
finite = FALSE) {
stopifnot(is.logical(na.rm))
vars <- intersect(vars, names(df))
if (name != "") name <- paste(" (", name, ")", sep = "")
if (finite) {
missing <- !finite.cases(df[, vars, drop = FALSE])
str <- "non-finite"
} else {
missing <- !stats::complete.cases(df[, vars, drop = FALSE])
str <- "missing"
}
if (any(missing)) {
df <- df[!missing, ]
if (!na.rm) {
warning_wrap(
"Removed ", sum(missing), " rows containing ", str, " values", name, "."
)
}
}
df
}
finite.cases <- function(x) UseMethod("finite.cases")
# 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.
#' @export
finite.cases.data.frame <- function(x) {
finite_cases <- vapply(x, is.finite, 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(finite_cases)) {
all(finite_cases)
} else {
# Find all the rows where all are TRUE
rowSums(as.matrix(finite_cases)) == ncol(x)
}
}
#' Used in examples to illustrate when errors should occur.
#'
#' @param expr code to evaluate.
#' @export
#' @keywords internal
#' @examples
#' should_stop(stop("Hi!"))
#' should_stop(should_stop("Hi!"))
should_stop <- function(expr) {
res <- try(print(force(expr)), TRUE)
if (!inherits(res, "try-error")) stop("No error!", call. = FALSE)
invisible()
}
#' A waiver object.
#'
#' A waiver is a "flag" object, similar to \code{NULL}, that indicates the
#' calling function should just use the default value. It is used in certain
#' functions to distinguish between displaying nothing (\code{NULL}) and
#' displaying a default value calculated elsewhere (\code{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])
}
#' Give a deprecation error, warning, or message, depending on version number.
#'
#' Version numbers have the format <major>.<minor>.<subminor>, like 0.9.2.
#' This function compares the current version number of ggplot2 against the
#' specified \code{version}, which is the most recent version before the
#' function (or other object) was deprecated.
#'
#' \code{gg_dep} will give an error, warning, or message, depending on the
#' difference between the current ggplot2 version and the specified
#' \code{version}.
#'
#' If the current major number is greater than \code{version}'s major number,
#' or if the current minor number is more than 1 greater than \code{version}'s
#' minor number, give an error.
#'
#' If the current minor number differs from \code{version}'s minor number by
#' one, give a warning.
#'
#' If the current subminor number differs from \code{version}'s subminor
#' number, print a message.
#'
#' @param version The last version of ggplot2 where this function was good
#' (in other words, the last version where it was not deprecated).
#' @param msg The message to print.
#' @keywords internal
#' @export
gg_dep <- function(version, msg) {
v <- as.package_version(version)
cv <- utils::packageVersion("ggplot2")
# If current major number is greater than last-good major number, or if
# current minor number is more than 1 greater than last-good minor number,
# give error.
if (cv[[1,1]] > v[[1,1]] || cv[[1,2]] > v[[1,2]] + 1) {
stop(msg, " (Defunct; last used in version ", version, ")",
call. = FALSE)
# If minor number differs by one, give warning
} else if (cv[[1,2]] > v[[1,2]]) {
warning(msg, " (Deprecated; last used in version ", version, ")",
call. = FALSE)
# If only subminor number is greater, give message
} else if (cv[[1,3]] > v[[1,3]]) {
message(msg, " (Deprecated; last used in version ", version, ")")
}
invisible()
}
has_name <- function(x) {
nms <- names(x)
if (is.null(nms)) {
return(rep(FALSE, length(x)))
}
!is.na(nms) & nms != ""
}
# Convert a snake_case string to camelCase
camelize <- function(x, first = FALSE) {
x <- gsub("_(.)", "\\U\\1", x, perl = TRUE)
if (first) x <- firstUpper(x)
x
}
snakeize <- function(x) {
x <- gsub("([A-Za-z])([A-Z])([a-z])", "\\1_\\2\\3", x)
x <- gsub(".", "_", x, fixed = TRUE)
x <- gsub("([a-z])([A-Z])", "\\1_\\2", x)
tolower(x)
}
firstUpper <- function(s) {
paste(toupper(substring(s, 1,1)), substring(s, 2), sep = "")
}
snake_class <- function(x) {
snakeize(class(x)[1])
}
empty <- function(df) {
is.null(df) || nrow(df) == 0 || ncol(df) == 0
}
is.discrete <- function(x) {
is.factor(x) || is.character(x) || is.logical(x)
}
compact <- function(x) {
null <- vapply(x, is.null, logical(1))
x[!null]
}
is.formula <- function(x) inherits(x, "formula")
deparse2 <- function(x) {
y <- deparse(x, backtick = TRUE)
if (length(y) == 1) {
y
} else {
paste0(y[[1]], "...")
}
}
message_wrap <- function(...) {
msg <- paste(..., collapse = "", sep = "")
wrapped <- strwrap(msg, width = getOption("width") - 2)
message(paste0(wrapped, collapse = "\n"))
}
warning_wrap <- function(...) {
msg <- paste(..., collapse = "", sep = "")
wrapped <- strwrap(msg, width = getOption("width") - 2)
warning(paste0(wrapped, collapse = "\n"), call. = FALSE)
}
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))]
utils::modifyList(vals, list(..., `...` = NULL))
}
# Used in annotations to ensure printed even when no
# global data
dummy_data <- function() data.frame(x = NA)
# Needed to trigger package loading
#' @importFrom tibble tibble
NULL
ggplot2/R/geom-.rMemoryTime
#' @include legend-draw.r
NULL
#' @section Geoms:
#'
#' All \code{geom_*} functions (like \code{geom_point}) return a layer that
#' contains a \code{Geom*} object (like \code{GeomPoint}). The \code{Geom*}
#' object is responsible for rendering the data in the plot.
#'
#' Each of the \code{Geom*} objects is a \code{\link{ggproto}} object, descended
#' from the top-level \code{Geom}, and each implements various methods and
#' fields. To create a new type of Geom object, you typically will want to
#' implement one or more of the following:
#'
#' Compared to \code{Stat} and \code{Position}, \code{Geom} is a little
#' different because the execution of the setup and compute functions is
#' split up. \code{setup_data} runs before position adjustments, and
#' \code{draw_layer} is not run until render time, much later. This
#' means there is no \code{setup_params} because it's hard to communicate
#' the changes.
#'
#' \itemize{
#' \item Override either \code{draw_panel(self, data, panel_scales, coord)} or
#' \code{draw_group(self, data, panel_scales, coord)}. \code{draw_panel} is
#' called once per panel, \code{draw_group} is called once per group.
#'
#' Use \code{draw_panel} if each row in the data represents a
#' single element. Use \code{draw_group} if each group represents
#' an element (e.g. a smooth, a violin).
#'
#' \code{data} is a data frame of scaled aesthetics. \code{panel_scales}
#' is a list containing information about the scales in the current
#' panel. \code{coord} is a coordinate specification. You'll
#' need to call \code{coord$transform(data, panel_scales)} to work
#' with non-Cartesian coords. 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 \code{\link{zeroGrob}} if there's nothing to
#' draw.
#' \item \code{draw_key}: Renders a single legend key.
#' \item \code{required_aes}: A character vector of aesthetics needed to
#' render the geom.
#' \item \code{default_aes}: A list (generated by \code{\link{aes}()} of
#' default values for aesthetics.
#' \item \code{reparameterise}: 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_scales), quote(coord)), params)
plyr::dlply(data, "PANEL", function(data) {
if (empty(data)) return(zeroGrob())
panel_scales <- layout$panel_ranges[[data$PANEL[1]]]
do.call(self$draw_panel, args)
}, .drop = FALSE)
},
draw_panel = function(self, data, panel_scales, coord, ...) {
groups <- split(data, factor(data$group))
grobs <- lapply(groups, function(group) {
self$draw_group(group, panel_scales, coord, ...)
})
ggname(snake_class(self), gTree(
children = do.call("gList", grobs)
))
},
draw_group = function(self, data, panel_scales, coord) {
stop("Not implemented")
},
setup_data = function(data, params) data,
# Combine data with defaults and set aesthetics from parameters
use_defaults = function(self, data, params = list()) {
# Fill in missing aesthetics with their defaults
missing_aes <- setdiff(names(self$default_aes), names(data))
if (empty(data)) {
data <- plyr::quickdf(self$default_aes[missing_aes])
} else {
data[missing_aes] <- self$default_aes[missing_aes]
}
# Override mappings with params
aes_params <- intersect(self$aesthetics(), names(params))
check_aesthetics(params[aes_params], nrow(data))
data[aes_params] <- params[aes_params]
data
},
# Most parameters for the geom are taken automatically from draw_panel() or
# draw_groups(). However, some additional parameters may be needed
# for setup_data() or handle_na(). These can not be imputed automatically,
# so the slightly hacky "extra_params" field is used instead. By
# default it contains `na.rm`
extra_params = c("na.rm"),
parameters = function(self, extra = FALSE) {
# Look first in draw_panel. If it contains ... then look in draw groups
panel_args <- names(ggproto_formals(self$draw_panel))
group_args <- names(ggproto_formals(self$draw_group))
args <- if ("..." %in% panel_args) group_args else panel_args
# Remove arguments of defaults
args <- setdiff(args, names(ggproto_formals(Geom$draw_group)))
if (extra) {
args <- union(args, self$extra_params)
}
args
},
aesthetics = function(self) {
c(union(self$required_aes, names(self$default_aes)), self$optional_aes, "group")
}
)
#' Graphical units
#'
#' Multiply size in mm by these constants in order to convert to the units
#' that grid uses internally for \code{lwd} and \code{fontsize}.
#'
#' @name graphical-units
#' @keywords internal
#' @aliases NULL
NULL
#' @export
#' @rdname graphical-units
.pt <- 72.27 / 25.4
#' @export
#' @rdname graphical-units
.stroke <- 96 / 25.4
check_aesthetics <- function(x, n) {
ns <- vapply(x, length, numeric(1))
good <- ns == 1L | ns == n
if (all(good)) {
return()
}
stop(
"Aesthetics must be either length 1 or the same as the data (", n, "): ",
paste(names(!good), collapse = ", "),
call. = FALSE
)
}
ggplot2/R/position-.rMemoryTime
#' @section Positions:
#'
#' All \code{position_*} functions (like \code{position_dodge}) return a
#' \code{Position*} object (like \code{PositionDodge}). The \code{Position*}
#' object is responsible for adjusting the position of overlapping geoms.
#'
#' The way that the \code{position_*} functions work is slightly different from
#' the \code{geom_*} and \code{stat_*} functions, because a \code{position_*}
#' function actually "instantiates" the \code{Position*} object by creating a
#' descendant, and returns that.
#'
#' Each of the \code{Position*} objects is a \code{\link{ggproto}} object,
#' descended from the top-level \code{Position}, and each implements the
#' following methods:
#'
#' \itemize{
#' \item \code{compute_layer(self, data, params, panel)} is called once
#' per layer. \code{panel} is currently an internal data structure, so
#' this method should not be overriden.
#'
#' \item \code{compute_panel(self, data, params, panel)} is called once per
#' panel and should return a modified data frame.
#'
#' \code{data} is a data frame containing the variables named according
#' to the aesthetics that they're mapped to. \code{scales} is a list
#' containing the \code{x} and \code{y} scales. There functions are called
#' before the facets are trained, so they are global scales, not local
#' to the individual panels. \code{params} contains the parameters returned by
#' \code{setup_params()}.
#' \item \code{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.
#' \item \code{setup_data(data, params)}: called once for each layer,
#' after \code{setp_params()}. Should return modified \code{data}.
#' Default checks that required aesthetics are present.
#' }
#'
#' And the following fields
#' \itemize{
#' \item \code{required_aes}: a character vector giving the aesthetics
#' that must be present for this position adjustment to work.
#' }
#'
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
Position <- ggproto("Position",
required_aes = character(),
setup_params = function(self, data) {
list()
},
setup_data = function(self, data, params) {
check_required_aesthetics(self$required_aes, names(data), snake_class(self))
data
},
compute_layer = function(self, data, params, layout) {
plyr::ddply(data, "PANEL", function(data) {
if (empty(data)) return(data.frame())
scales <- layout$get_scales(data$PANEL[1])
self$compute_panel(data = data, params = params, scales = scales)
})
},
compute_panel = function(self, data, params, scales) {
stop("Not implemented", call. = FALSE)
}
)
#' Convenience function to transform all position variables.
#'
#' @param trans_x,trans_y Transformation functions for x and y aesthetics.
#' (will transform x, xmin, xmax, xend etc)
#' @param ... Additional arguments passed to \code{trans_x} and \code{trans_y}.
#' @keywords internal
#' @export
transform_position <- function(df, trans_x = NULL, trans_y = NULL, ...) {
scales <- aes_to_scale(names(df))
if (!is.null(trans_x)) {
df[scales == "x"] <- lapply(df[scales == "x"], trans_x, ...)
}
if (!is.null(trans_y)) {
df[scales == "y"] <- lapply(df[scales == "y"], trans_y, ...)
}
df
}
ggplot2/R/utilities-grid.rMemoryTime
#' @export
grid::unit
#' @export
grid::arrow
# Name ggplot grid object
# Convenience function to name grid objects
#
# @keyword internal
ggname <- function(prefix, grob) {
grob$name <- grobName(grob, prefix)
grob
}
width_cm <- function(x) {
if (is.grob(x)) {
convertWidth(grobWidth(x), "cm", TRUE)
} else if (is.unit(x)) {
convertWidth(x, "cm", TRUE)
} else if (is.list(x)) {
vapply(x, width_cm, numeric(1))
} else {
stop("Unknown input")
}
}
height_cm <- function(x) {
if (is.grob(x)) {
convertWidth(grobHeight(x), "cm", TRUE)
} else if (is.unit(x)) {
convertHeight(x, "cm", TRUE)
} else if (is.list(x)) {
vapply(x, height_cm, numeric(1))
} else {
stop("Unknown input")
}
}
ggplot2/R/theme-elements.rMemoryTime
#' Theme elements
#'
#' @description
#' In conjunction with the \link{theme} system, the \code{element_} functions
#' specify the display of how non-data components of the plot are a drawn.
#'
#' \itemize{
#' \item \code{element_blank}: draws nothing, and assigns no space.
#' \item \code{element_rect}: borders and backgrounds.
#' \item \code{element_line}: lines.
#' \item \code{element_text}: text.
#' }
#'
#' \code{rel()} is used to specify sizes relative to the parent,
#' \code{margins()} is used to specify the margins of elements.
#'
#' @param fill Fill colour.
#' @param colour,color Line/border colour. Color is an alias for colour.
#' @param size Line/border size in mm; text size in pts.
#' @param inherit.blank Should this element inherit the existence of an
#' \code{element_blank} among its parents? If \code{TRUE} the existence of
#' a blank element among its parents will cause this element to be blank as
#' well. If \code{FALSE} any blank parent element will be ignored when
#' calculating final element state.
#' @return An S3 object of class \code{element}, \code{rel}, or \code{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 \code{\link[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 [0, 1])
#' @param vjust Vertical justification (in [0, 1])
#' @param angle Angle (in [0, 360])
#' @param lineheight Line height
#' @param margin Margins around the text. See \code{\link{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 \code{TRUE}, aids visual debugging by drawing a solid
#' rectangle behind the complete text area, and a point where each label
#' is anchored.
#' @export
#' @rdname element
element_text <- function(family = NULL, face = NULL, colour = NULL,
size = NULL, hjust = NULL, vjust = NULL, angle = NULL, lineheight = NULL,
color = NULL, margin = NULL, debug = NULL, inherit.blank = FALSE) {
if (!is.null(color)) colour <- color
structure(
list(family = family, face = face, colour = colour, size = size,
hjust = hjust, vjust = vjust, angle = angle, lineheight = lineheight,
margin = margin, debug = debug, inherit.blank = inherit.blank),
class = c("element_text", "element")
)
}
#' @export
print.element <- function(x, ...) utils::str(x)
#' @param x A single number specifying size relative to parent element.
#' @rdname element
#' @export
rel <- function(x) {
structure(x, class = "rel")
}
#' @export
print.rel <- function(x, ...) print(noquote(paste(x, " *", sep = "")))
#' Reports whether x is a rel object
#' @param x An object to test
#' @keywords internal
is.rel <- function(x) inherits(x, "rel")
# Given a theme object and element name, return a grob for the element
element_render <- function(theme, element, ..., name = NULL) {
# Get the element from the theme, calculating inheritance
el <- calc_element(element, theme)
if (is.null(el)) {
message("Theme element ", element, " missing")
return(zeroGrob())
}
grob <- element_grob(el, ...)
ggname(paste(element, name, sep = "."), grob)
}
# Returns NULL if x is length 0
len0_null <- function(x) {
if (length(x) == 0) NULL
else x
}
#' Generate grid grob from theme element
#'
#' @param element Theme element, i.e. \code{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 = utils::modifyList(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, expand_x = FALSE, expand_y = FALSE, ...) {
if (is.null(label))
return(zeroGrob())
vj <- vjust %||% element$vjust
hj <- hjust %||% element$hjust
margin <- margin %||% element$margin
angle <- angle %||% element$angle
if (is.null(angle)) {
stop("Text element requires non-NULL value for 'angle'.")
}
# 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 = utils::modifyList(element_gp, gp), margin = margin,
expand_x = expand_x, expand_y = expand_y, debug = element$debug)
}
#' @export
element_grob.element_line <- function(element, x = 0:1, y = 0:1,
colour = NULL, size = NULL, linetype = NULL, lineend = NULL,
default.units = "npc", id.lengths = NULL, ...) {
# The gp settings can override element_gp
gp <- gpar(lwd = len0_null(size * .pt), col = colour, lty = linetype, lineend = lineend)
element_gp <- gpar(lwd = len0_null(element$size * .pt), col = element$colour,
lty = element$linetype, lineend = element$lineend)
arrow <- if (is.logical(element$arrow) && !element$arrow) {
NULL
} else {
element$arrow
}
polylineGrob(
x, y, default.units = default.units,
gp = utils::modifyList(element_gp, gp),
id.lengths = id.lengths, arrow = arrow, ...
)
}
# Define an element's class and what other elements it inherits from
#
# @param class The name of class (like "element_line", "element_text",
# or the reserved "character", which means a character vector (not
# "character" class)
# @param inherit A vector of strings, naming the elements that this
# element inherits from.
el_def <- function(class = NULL, inherit = NULL, description = NULL) {
list(class = class, inherit = inherit, description = description)
}
# This data structure represents the theme elements and the inheritance
# among them.
.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.y = el_def("element_line", "axis.line"),
axis.text.x = el_def("element_text", "axis.text"),
axis.text.x.top = el_def("element_text", "axis.text.x"),
axis.text.y = el_def("element_text", "axis.text"),
axis.text.y.right = el_def("element_text", "axis.text.y"),
axis.ticks.length = el_def("unit"),
axis.ticks.x = el_def("element_line", "axis.ticks"),
axis.ticks.y = el_def("element_line", "axis.ticks"),
axis.title.x = el_def("element_text", "axis.title"),
axis.title.x.top = el_def("element_text", "axis.title.x"),
axis.title.y = el_def("element_text", "axis.title"),
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.text.x = el_def("element_text", "strip.text"),
strip.text.y = el_def("element_text", "strip.text"),
strip.placement = el_def("character"),
strip.placement.x = el_def("character", "strip.placement"),
strip.placement.y = el_def("character", "strip.placement"),
strip.switch.pad.grid = el_def("unit"),
strip.switch.pad.wrap = el_def("unit"),
plot.background = el_def("element_rect", "rect"),
plot.title = el_def("element_text", "title"),
plot.subtitle = el_def("element_text", "title"),
plot.caption = el_def("element_text", "title"),
plot.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
validate_element <- function(el, elname) {
eldef <- .element_tree[[elname]]
if (is.null(eldef)) {
stop('"', elname, '" is not a valid theme element name.')
}
# NULL values for elements are OK
if (is.null(el)) return()
if (eldef$class == "character") {
# Need to be a bit looser here since sometimes it's a string like "top"
# but sometimes its a vector like c(0,0)
if (!is.character(el) && !is.numeric(el))
stop("Element ", elname, " must be a string or numeric vector.")
} else if (eldef$class == "margin") {
if (!is.unit(el) && length(el) == 4)
stop("Element ", elname, " must be a unit vector of length 4.")
} else if (!inherits(el, eldef$class) && !inherits(el, "element_blank")) {
stop("Element ", elname, " must be a ", eldef$class, " object.")
}
invisible()
}
ggplot2/R/guides-grid.rMemoryTime
# Produce a grob to be used as for panel backgrounds
guide_grid <- function(theme, x.minor, x.major, y.minor, y.major) {
x.minor <- setdiff(x.minor, x.major)
y.minor <- setdiff(y.minor, y.major)
ggname("grill", grobTree(
element_render(theme, "panel.background"),
if (length(y.minor) > 0) element_render(
theme, "panel.grid.minor.y",
x = rep(0:1, length(y.minor)), y = rep(y.minor, each = 2),
id.lengths = rep(2, length(y.minor))
),
if (length(x.minor) > 0) element_render(
theme, "panel.grid.minor.x",
x = rep(x.minor, each = 2), y = rep(0:1, length(x.minor)),
id.lengths = rep(2, length(x.minor))
),
if (length(y.major) > 0) element_render(
theme, "panel.grid.major.y",
x = rep(0:1, length(y.major)), y = rep(y.major, each = 2),
id.lengths = rep(2, length(y.major))
),
if (length(x.major) > 0) element_render(
theme, "panel.grid.major.x",
x = rep(x.major, each = 2), y = rep(0:1, length(x.major)),
id.lengths = rep(2, length(x.major))
)
))
}
ggplot2/R/coord-.rMemoryTime
#' @section Coordinate systems:
#'
#' All \code{coord_*} functions (like \code{coord_trans}) return a \code{Coord*}
#' object (like \code{CoordTrans}). The \code{Coord*} object is responsible for
#' adjusting the position of overlapping geoms.
#'
#' The way that the \code{coord_*} functions work is slightly different from the
#' \code{geom_*} and \code{stat_*} functions, because a \code{coord_*} function
#' actually "instantiates" the \code{Coord*} object by creating a descendant,
#' and returns that.
#'
#' Each of the \code{Coord*} objects is a \code{\link{ggproto}} object,
#' descended from the top-level \code{Coord}. To create a new type of Coord
#' object, you typically will want to implement one or more of the following:
#'
#' \itemize{
#' \item \code{aspect}: Returns the desired aspect ratio for the plot.
#' \item \code{labels}: Returns a list containing labels for x and y.
#' \item \code{render_fg}: Renders foreground elements.
#' \item \code{render_bg}: Renders background elements.
#' \item \code{render_axis_h}: Renders the horizontal axes.
#' \item \code{render_axis_v}: Renders the vertical axes.
#' \item \code{range}: Returns the x and y ranges
#' \item \code{train}: Return the trained scale ranges.
#' \item \code{transform}: Transforms x and y coordinates.
#' \item \code{distance}: Calculates distance.
#' \item \code{is_linear}: Returns \code{TRUE} if the coordinate system is
#' linear; \code{FALSE} otherwise.
#' }
#'
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
Coord <- ggproto("Coord",
aspect = function(ranges) NULL,
labels = function(scale_details) scale_details,
render_fg = function(scale_details, theme) element_render(theme, "panel.border"),
render_bg = function(scale_details, theme) {
x.major <- if (length(scale_details$x.major) > 0) unit(scale_details$x.major, "native")
x.minor <- if (length(scale_details$x.minor) > 0) unit(scale_details$x.minor, "native")
y.major <- if (length(scale_details$y.major) > 0) unit(scale_details$y.major, "native")
y.minor <- if (length(scale_details$y.minor) > 0) unit(scale_details$y.minor, "native")
guide_grid(theme, x.minor, x.major, y.minor, y.major)
},
render_axis_h = function(scale_details, theme) {
arrange <- scale_details$x.arrange %||% c("secondary", "primary")
list(
top = render_axis(scale_details, arrange[1], "x", "top", theme),
bottom = render_axis(scale_details, arrange[2], "x", "bottom", theme)
)
},
render_axis_v = function(scale_details, theme) {
arrange <- scale_details$y.arrange %||% c("primary", "secondary")
list(
left = render_axis(scale_details, arrange[1], "y", "left", theme),
right = render_axis(scale_details, arrange[2], "y", "right", theme)
)
},
range = function(scale_details) {
return(list(x = scale_details$x.range, y = scale_details$y.range))
},
train = function(scale_details) NULL,
transform = function(data, range) NULL,
distance = function(x, y, scale_details) NULL,
is_linear = function() FALSE
)
#' Is this object a coordinate system?
#'
#' @export is.Coord
#' @keywords internal
is.Coord <- function(x) inherits(x, "Coord")
expand_default <- function(scale, discrete = c(0, 0.6), continuous = c(0.05, 0)) {
scale$expand %|W|% if (scale$is_discrete()) discrete else continuous
}
# Renders an axis with the correct orientation or zeroGrob if no axis should be
# generated
render_axis <- function(scale_details, axis, scale, position, theme) {
if (axis == "primary") {
guide_axis(scale_details[[paste0(scale, ".major")]], scale_details[[paste0(scale, ".labels")]], position, theme)
} else if (axis == "secondary" && !is.null(scale_details[[paste0(scale, ".sec.major")]])) {
guide_axis(scale_details[[paste0(scale, ".sec.major")]], scale_details[[paste0(scale, ".sec.labels")]], position, theme)
} else {
zeroGrob()
}
}
ggplot2/R/margins.RMemoryTime
#' @param t,r,b,l Dimensions of each margin. (To remember order, think trouble).
#' @param unit Default units of dimensions. Defaults to "pt" so it
#' can be most easily scaled with the text.
#' @rdname element
#' @export
margin <- function(t = 0, r = 0, b = 0, l = 0, unit = "pt") {
structure(unit(c(t, r, b, l), unit), class = c("margin", "unit"))
}
is.margin <- function(x) {
inherits(x, "margin")
}
margin_height <- function(grob, margins) {
if (is.zero(grob)) return(unit(0, "cm"))
grobHeight(grob) + margins[1] + margins[3]
}
margin_width <- function(grob, margins) {
if (is.zero(grob)) return(unit(0, "cm"))
grobWidth(grob) + margins[2] + margins[4]
}
titleGrob <- function(label, x, y, hjust, vjust, angle = 0, gp = gpar(),
margin = NULL, expand_x = FALSE, expand_y = FALSE,
debug = FALSE) {
if (is.null(label))
return(zeroGrob())
if (is.null(margin)) {
margin <- margin(0, 0, 0, 0)
}
angle <- angle %% 360
if (angle == 90) {
xp <- 1 - vjust
yp <- hjust
} else if (angle == 180) {
xp <- 1 - hjust
yp <- 1 - vjust
} else if (angle == 270) {
xp <- vjust
yp <- 1 - hjust
} else {
xp <- hjust
yp <- vjust
}
n <- max(length(x), length(y), 1)
x <- x %||% unit(rep(xp, n), "npc")
y <- y %||% unit(rep(yp, n), "npc")
text_grob <- textGrob(label, x, y, hjust = hjust, vjust = vjust,
rot = angle, gp = gp)
# The grob dimensions don't include the text descenders, so add on using
# a little trigonometry. This is only exactly correct when vjust = 1.
descent <- descentDetails(text_grob)
text_height <- unit(1, "grobheight", text_grob) + cos(angle / 180 * pi) * descent
text_width <- unit(1, "grobwidth", text_grob) + sin(angle / 180 * pi) * descent
if (expand_x && expand_y) {
widths <- unit.c(margin[4], text_width, margin[2])
heights <- unit.c(margin[1], text_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 (expand_x) {
widths <- unit.c(margin[4], text_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 (expand_y) {
heights <- unit.c(margin[1], text_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 {
return(text_grob)
}
if (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)
}
gTree(
children = children,
vp = vpTree(vp, vpList(child_vp)),
widths = widths,
heights = heights,
cl = "titleGrob"
)
}
#' @export
widthDetails.titleGrob <- function(x) {
sum(x$widths)
}
#' @export
heightDetails.titleGrob <- function(x) {
sum(x$heights)
}
# Works like titleGrob, but designed to place one label per viewport.
# This means it doesn't have the lengths of labels available, so must use
# alternative layout strategy
stripGrob <- function(label, hjust, vjust, angle = 0, gp = gpar(),
margin = NULL, debug = FALSE) {
if (is.null(margin)) {
margin <- margin()
}
text_grob <- textGrob(label, rot = angle, gp = gp)
widths <- unit.c(margin[4], unit(1, "grobwidth", text_grob), margin[2])
heights <- unit.c(margin[1], unit(1, "grobheight", text_grob), margin[3])
vp <- viewport(
hjust, vjust, just = c(hjust, vjust),
width = sum(widths),
height = sum(heights),
layout = grid.layout(3, 3, heights = heights, widths = widths),
name = "top"
)
child_vp <- viewport(layout.pos.row = 2, layout.pos.col = 2)
if (debug) {
children <- gList(
rectGrob(gp = gpar(fill = "cornsilk", col = NA)),
pointsGrob(unit(hjust, "npc"), unit(vjust, "npc"), pch = 20,
gp = gpar(col = "gold")),
text_grob
)
} else {
children <- gList(text_grob)
}
gTree(
children = children,
vp = vpTree(vp, vpList(child_vp)),
widths = widths,
heights = heights,
cl = "stripGrob"
)
}
#' @export
widthDetails.stripGrob <- function(x) {
sum(x$widths)
}
#' @export
heightDetails.stripGrob <- function(x) {
sum(x$heights)
}
ggplot2/R/guides-axis.rMemoryTime
# Grob for axes
#
# @param position of ticks
# @param labels at ticks
# @param position of axis (top, bottom, left or right)
# @param range of data values
guide_axis <- function(at, labels, position = "right", theme) {
if (length(at) == 0)
return(zeroGrob())
at <- unit(at, "native")
position <- match.arg(position, c("top", "bottom", "right", "left"))
zero <- unit(0, "npc")
one <- unit(1, "npc")
label_render <- switch(position,
top = "axis.text.x.top", bottom = "axis.text.x",
left = "axis.text.y", right = "axis.text.y.right"
)
label_x <- switch(position,
top = ,
bottom = at,
right = theme$axis.ticks.length,
left = one - theme$axis.ticks.length
)
label_y <- switch(position,
top = theme$axis.ticks.length,
bottom = one - theme$axis.ticks.length,
right = ,
left = at
)
if (is.list(labels)) {
if (any(sapply(labels, is.language))) {
labels <- do.call(expression, labels)
} else {
labels <- unlist(labels)
}
}
labels <- switch(position,
top = ,
bottom = element_render(theme, label_render, labels, x = label_x, expand_y = TRUE),
right = ,
left = element_render(theme, label_render, labels, y = label_y, expand_x = TRUE))
line <- switch(position,
top = element_render(theme, "axis.line.x", c(0, 1), c(0, 0), id.lengths = 2),
bottom = element_render(theme, "axis.line.x", c(0, 1), c(1, 1), id.lengths = 2),
right = element_render(theme, "axis.line.y", c(0, 0), c(0, 1), id.lengths = 2),
left = element_render(theme, "axis.line.y", c(1, 1), c(0, 1), id.lengths = 2)
)
nticks <- length(at)
ticks <- switch(position,
top = element_render(theme, "axis.ticks.x",
x = rep(at, each = 2),
y = rep(unit.c(zero, theme$axis.ticks.length), nticks),
id.lengths = rep(2, nticks)),
bottom = element_render(theme, "axis.ticks.x",
x = rep(at, each = 2),
y = rep(unit.c(one - theme$axis.ticks.length, one), nticks),
id.lengths = rep(2, nticks)),
right = element_render(theme, "axis.ticks.y",
x = rep(unit.c(zero, theme$axis.ticks.length), nticks),
y = rep(at, each = 2),
id.lengths = rep(2, nticks)),
left = element_render(theme, "axis.ticks.y",
x = rep(unit.c(one - theme$axis.ticks.length, one), nticks),
y = rep(at, each = 2),
id.lengths = rep(2, nticks))
)
# Create the gtable for the ticks + labels
gt <- switch(position,
top = gtable_col("axis",
grobs = list(labels, ticks),
width = one,
heights = unit.c(grobHeight(labels), theme$axis.ticks.length)
),
bottom = gtable_col("axis",
grobs = list(ticks, labels),
width = one,
heights = unit.c(theme$axis.ticks.length, grobHeight(labels))
),
right = gtable_row("axis",
grobs = list(ticks, labels),
widths = unit.c(theme$axis.ticks.length, grobWidth(labels)),
height = one
),
left = gtable_row("axis",
grobs = list(labels, ticks),
widths = unit.c(grobWidth(labels), theme$axis.ticks.length),
height = one
)
)
# Viewport for justifying the axis grob
justvp <- switch(position,
top = viewport(y = 0, just = "bottom", height = gtable_height(gt)),
bottom = viewport(y = 1, just = "top", height = gtable_height(gt)),
right = viewport(x = 0, just = "left", width = gtable_width(gt)),
left = viewport(x = 1, just = "right", width = gtable_width(gt))
)
absoluteGrob(
gList(line, gt),
width = gtable_width(gt),
height = gtable_height(gt),
vp = justvp
)
}
ggplot2/R/facet-null.rMemoryTime
#' @include facet-.r
NULL
#' Facet specification: a single panel.
#'
#' @inheritParams facet_grid
#' @keywords internal
#' @export
#' @examples
#' # facet_null is the default facetting specification if you
#' # don't override it with facet_grid or facet_wrap
#' ggplot(mtcars, aes(mpg, wt)) + geom_point()
facet_null <- function(shrink = TRUE) {
ggproto(NULL, FacetNull,
shrink = shrink
)
}
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
FacetNull <- ggproto("FacetNull", Facet,
shrink = TRUE,
compute_layout = function(data, params) {
layout_null()
},
map_data = function(data, layout, params) {
# Need the is.waive check for special case where no data, but aesthetics
# are mapped to vectors
if (is.waive(data) || empty(data))
return(cbind(data, PANEL = integer(0)))
data$PANEL <- 1L
data
},
draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) {
range <- ranges[[1]]
# Figure out aspect ratio
aspect_ratio <- theme$aspect.ratio %||% coord$aspect(range)
if (is.null(aspect_ratio)) {
aspect_ratio <- 1
respect <- FALSE
} else {
respect <- TRUE
}
axis_h <- coord$render_axis_h(range, theme)
axis_v <- coord$render_axis_v(range, theme)
all <- matrix(list(
zeroGrob(), axis_h$top, zeroGrob(),
axis_v$left, panels[[1]], axis_v$right,
zeroGrob(), axis_h$bottom, zeroGrob()
), ncol = 3, byrow = TRUE)
z_matrix <- matrix(c(5, 6, 4, 7, 1, 8, 3, 9, 2), ncol = 3, byrow = TRUE)
grob_widths <- unit.c(grobWidth(axis_v$left), unit(1, "null"), grobWidth(axis_v$right))
grob_heights <- unit.c(grobHeight(axis_h$top), unit(aspect_ratio, "null"), grobHeight(axis_h$bottom))
grob_names <- c("spacer", "axis-l", "spacer", "axis-t", "panel", "axis-b", "spacer", "axis-r", "spacer")
grob_clip <- c("off", "off", "off", "off", "on", "off", "off", "off", "off")
layout <- gtable_matrix("layout", all,
widths = grob_widths, heights = grob_heights,
respect = respect, clip = grob_clip,
z = z_matrix
)
layout$layout$name <- grob_names
layout
},
vars = function(self) {
""
}
)
ggplot2/R/grob-absolute.rMemoryTime
#' 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()
}
printprint.ggplotggplot_buildfffffffFUNfffffMapggplot_gtableMapmapplyflayout$renderfffFUNffgrid.drawgrid.draw.gTreerecordGraphicsdrawGTreegrid.drawgrid.draw.gTreerecordGraphics02004006008001,0001,2001,4001,6001,800
Sample Interval: 10ms
1830ms

Can I profile code without calling profvis()?

Yes. There are two ways to do it.

If you are in RStudio, you can select Profile->Start Profiling, run your code, and then Profile->Stop Profiling. When you stop the profiling, the profvis viewer will come up.

Another way is to start and stop the R profiler manually, then have profvis read in the recorded profiling data. To profile your code, run:

# Start profiler
Rprof("data.Rprof", interval = 0.01, line.profiling = TRUE,
      gc.profiling = TRUE, memory.profiling = TRUE)

## Run your code here

# Stop profiler
Rprof(NULL)

Then you can load the data into profvis:

profvis(prof_input = "data.Rprof")

This technique can also be used to profile just one section of your code.

Why does the flame graph hide some function calls for Shiny apps?

When profiling Shiny applications, the profvis flame graph will hide many function calls by default. They’re hidden because they aren’t particularly informative for optimizing code, and they add visual complexity. This feature requires Shiny 0.13.0 or greater.

If you want to see these hidden blocks, uncheck Options -> Hide internal function calls:

library(shiny)
profvis({
  # After this app has started, interact with it a bit, then quit
  runExample("06_tabsets", display.mode = "normal")
})
Flame Graph
Data
Options ▾
<expr>MemoryTime
p <- profvis({
runExample("06_tabsets", display.mode = "normal")
})
/Library/Frameworks/R.framework/Versions/3.3/Resources/library/shiny/examples/06_tabsets/server.RMemoryTime
library(shiny)
# Define server logic for random distribution application
function(input, output) {
# Reactive expression to generate the requested distribution.
# This is called whenever the inputs change. The output
# functions defined below then all use the value computed from
# this expression
data <- reactive({
dist <- switch(input$dist,
norm = rnorm,
unif = runif,
lnorm = rlnorm,
exp = rexp,
rnorm)
dist(input$n)
})
# Generate a plot of the data. Also uses the inputs to build
# the plot label. Note that the dependencies on both the inputs
# and the data reactive expression are both tracked, and
# all expressions are called in the sequence implied by the
# dependency graph
output$plot <- renderPlot({
dist <- input$dist
n <- input$n
hist(data(),
main=paste('r', dist, '(', n, ')', sep=''))
})
# Generate a summary of the data
output$summary <- renderPrint({
summary(data())
})
# Generate an HTML table view of the data
output$table <- renderTable({
data.frame(x=data())
})
}
runExamplerunAppoutput$plotplotObj<reactive:plotObj>renderPlothisthist.defaultplotoutput$plotplotObj<reactive:plotObj>renderPlothisthist.defaultplot050100150200250300350400450
Sample Interval: 10ms
480ms

To make the hiding work, Shiny has special functions called ..stacktraceon.. and ..stacktraceoff... Profvis goes up the stack, and when it sees a ..stacktraceoff.., it will hide all function calls until it sees a corresponding ..stacktraceon... If there are nukltiple ..stacktraceoff.. calls in the stack, it requires an equal number of ..stacktraceon.. calls before it starts displaying function calls again.

Can I profile just part of a Shiny application?

Sometimes it it useful to profile just part of a Shiny application, instead of the whole thing from start to finish.

If you are in RStudio, you can start your application, then select Profile->Start Profiling, interact with your application, and then select Profile->Stop Profiling. When you stop the profiling, the profvis viewer will come up.

Profivs also provides a Shiny Module to initiate the profiling, and provides a UI to start, stop, view, and download profvis sessions. This is done with profvis::profvis_server and profvis::profvis_ui.

For example, here’s a small app that uses the module:

library(shiny)
library(ggplot2)
library(profvis)
shinyApp(
  fluidPage(
    plotOutput("plot"),
    actionButton("new", "New plot"),
    profvis_ui("profiler")
  ),
  function(input, output, session) {
    callModule(profvis_server, "profiler")
  
    output$plot <- renderPlot({
      input$new
      ggplot(diamonds, aes(carat, price)) + geom_point()
    })
  }
)

In the server function, callModule(profvis_server, "profiler") sets up the profvis session, and in the UI profvis_ui("profiler") sets up a basic interface to start, stop, view, and download profvis sessions.

You can create your own profvis_server and profvis_ui functions by calling Rprof() to start and stop profiling (as described in this answer), and trigger it with an actionButton. For example, you could put this in your UI:

  radioButtons("profile", "Profiling", c("off", "on"))

And put this in your server function:

  observe({
    if (identical(input$profile, "off")) {
      Rprof(NULL)
    } else if (identical(input$profile, "on")){
      Rprof(strftime(Sys.time(), "%Y-%m-%d-%H-%M-%S.Rprof"),
            interval = 0.01, line.profiling = TRUE,
            gc.profiling = TRUE, memory.profiling = TRUE)
    }
  })

It will add radio buttons to turn profiling on and off. Turn it on, then interact with your app, then turn it off. There will be a file with a name corresponding to the start time. You can view the profiler output with profvis, with something like this:

  profvis(prof_input = "2018-08-07-12-22-35.Rprof")

Can I profile a Shiny application running on a remote server?

Yes. One option is to include the Profvis Shiny Module desribed in the previous question.

You can also set it up manually. The main idea is to start and stop profiling (as described in this answer). At the top of your app.R or server.R, you can add the following:

Rprof(strftime(Sys.time(), "%Y-%m-%d-%H-%M-%S.Rprof"),
      interval = 0.01, line.profiling = TRUE,
      gc.profiling = TRUE, memory.profiling = TRUE)

onStop(function() {
  Rprof(NULL)
})

This will start profiling when the app starts, and stop when it exits.

Why does Sys.sleep() not show up in profiler data?

The R profiler doesn’t provide any data when R makes a system call. If, for example, you call Sys.sleep(5), the R process will pause for 5 seconds, but you probably won’t see any instances of Sys.sleep in the profvis visualization – it won’t even take any horizontal space. For these examples, we’ve used the pause function instead, which is part of the profvis package. It’s similar to Sys.sleep, except that it does show up in the profiling data. For example:

profvis({
  # Does not show in the flame graph
  Sys.sleep(0.25)

  # Does show in the flame graph
  pause(0.25)
})
Flame Graph
Data
Options ▾
<expr>MemoryTime
profvis({
# Does not show in the flame graph
Sys.sleep(0.25)
# Does show in the flame graph
pause(0.25)
})
pause020406080100120140160180200
Sample Interval: 10ms
200ms

Calls to external programs and libraries also may not show up in the profiling data. If you call functions from a package to fetch data from external sources, keep in mind that time spent in those functions may not show in the profiler.

Why is the call stack reversed for some of my code?

One of the unusual features of R as a programming language is that it has lazy evaluation of function arguments. If you pass an expression to a function, that expression won’t be evaluated until it’s actually used somewhere in that function.

The result of this is that sometimes the stack can look like it’s in the wrong order. In this example below, we call times_10 and times_10_lazy. They both call times_5() and times_2(), but the “regular” version uses an intermediate variable y, while the lazy version nests the calls, with times_2(times_5(x)).

profvis({
  times_5 <- function(x) {
    pause(0.5)
    x * 5
  }

  times_2 <- function(x) {
    pause(0.2)
    x * 2
  }

  times_10 <- function(x) {
    y <- times_5(x)
    times_2(y)
  }

  times_10_lazy <- function(x) {
    times_2(times_5(x))
  }

  times_10(10)
  times_10_lazy(10)
})
Flame Graph
Data
Options ▾
<expr>MemoryTime
profvis({
times_5 <- function(x) {
pause(0.5)
x * 5
}
times_2 <- function(x) {
pause(0.2)
x * 2
}
times_10 <- function(x) {
y <- times_5(x)
times_2(y)
}
times_10_lazy <- function(x) {
times_2(times_5(x))
}
times_10(10)
times_10_lazy(10)
})
times_10times_5pausetimes_2pausetimes_10_lazytimes_2pausetimes_5pause01002003004005006007008009001,0001,100
Sample Interval: 10ms
1150ms

In most programming languages, the flame graph would look the same for both: the times_10 (or times_10_lazy) block would be on the bottom, with times_5 and times_2 side-by-side on the next level up on the stack.

With lazy evaluation, when the times_10_lazy function calls times_2(times_5(x)), the times_2 function receives a promise with the unevaluated expression times_5(x), and evaluates it only when it reaches line 9, x * 2 (the expression gets evaluated in the correct context, so there’s no naming collision of the x variable).

It’s not only the call stack that has a surprising order with times_10_lazy – the temporal order the simulated work we’re doing in the function (represented by the pause blocks) is different. The times_2 and times_5 functions pause for 0.2 and 0.5 seconds, respectively. Those pauses occur in opposite order in times_10 and times_10_lazy.

Keep in mind that lazy evaluation may result in counterintuitive results in the flame graph. If you want to avoid some of the possible confusion from lazy evaluation, you can use intermediate variables to force the evaluation of arguments at specific locations in your code, as we did in times_10.

Why does profvis tell me the the wrong line is taking time?

In some cases, multi-line expressions will report that the first line of the expression is the one that takes all the time. In the example below, there are two for loops: one with curly braces, and one without. In the loop with curly braces, it reports that line 3, containing the pause is the one that takes all the time. In the loop without curly braces, it reports that line 6, containing for, is the one that takes all the time, even though the time is really spent on line 7, with the pause.

profvis({
  for (i in 1:3) {
    pause(0.1)
  }

  for (i in 1:3)
    pause(0.1)

})
Flame Graph
Data
Options ▾
<expr>MemoryTime
profvis({
for (i in 1:3) {
pause(0.1)
}
for (i in 1:3)
pause(0.1)
})
pausepause050100150200250300350400450500
Sample Interval: 10ms
500ms

For code that contains multi-line expressions like these, using curly braces will allow the profiler to identify the correct line where code is running.

How do I interpret memory profiling information?

The memory profiling information can be somewhat tricky to interpret, for two reasons. The first reason is that, compared to call stack information, memory usage information is collected with different temporal characteristics: call stack information is recorded instantaneously at each sample, while memory information is recorded between each sample.

The second reason that is that memory deallocations happen somewhat randomly, and may happen long after the point where the memory was no longer needed. The deallocations occur in garbage collection (<GC>) events.

For these reasons, it might look like a particular line of code (or function call in the flame graph) is responsible for memory allocation or deallocation, when in reality the memory use is due to a previous line of code.

If a section of code results in a large amount of allocation and deallocation, it means that it’s “churning” through memory and using a large amonut of temporary memory storage. This can be seen in Example 1 above. In these cases, it may be possible to optimize the code so that it doesn’t use as much temporary memory.

If a section of code results in a large amount of allocation but does not have a large amount of deallocation, then it means the memory is not being released. This could be because the code genuinely requires that extra memory, but it could also be a sign of a memory leak.

How do I split the panes vertically instead of horizontally?

The profvis examples in this document have a vertical split, but by default, profvis visualizations have a horizontal split. To switch directions, you can check or uncheck Options -> Split horizontally.

To change the split direction when the visualization opens, use split="v":

profvis({
  # Code here
}, split = "v")


# Also possible to control the split when calling print()
p <- profvis({
  # Code here
})
print(p, split = "v")

How do I get source code to show with Rscript?

If you run profvis from a script, the source code won’t show in the source panel. This is because source refs are not recorded by default when R is run non-interactively. To make it work, use options(keep.source=TRUE). For example:

Rscript -e "options(keep.source=TRUE); p <- profvis::profvis({ profvis::pause(0.2) }); htmlwidgets::saveWidget(p, 'test.html')"

What are some other resources for profiling R code?

Base R comes with the Rprof function (it’s what profvis calls to collect profiling data) as well as the summaryRprof function for getting a human-readable summary of the profiling data collected by Rprof.

Luke Tierney and Riad Jarjour have authored the proftools package, which provides many more tools for summarizing profiling data, including hot paths, call summaries, and call graphs. Proftools can also be used to generate a number of visualizations, including call graphs, flame graphs, and callee tree maps.