mirror of
https://github.com/rstudio/shiny.git
synced 2026-04-07 03:00:20 -04:00
Restructure code for clarity
This commit is contained in:
Winston Chang
739
R/render-plot.R
739
R/render-plot.R
@@ -427,216 +427,185 @@ getPrevPlotCoordmap <- function(width, height) {
|
||||
|
||||
# Given a ggplot_build_gtable object, return a coordmap for it.
|
||||
getGgplotCoordmap <- function(p, pixelratio, res) {
|
||||
# Structure of ggplot objects changed after 2.1.0. After 2.2.1, there was a
|
||||
# an API for extracting the necessary information.
|
||||
ggplot_ver <- utils::packageVersion("ggplot2")
|
||||
if (ggplot_ver > "2.2.1") {
|
||||
ggplot_format <- "api"
|
||||
} else if (ggplot_ver > "2.1.0") {
|
||||
ggplot_format <- "new"
|
||||
} else {
|
||||
ggplot_format <- "old"
|
||||
}
|
||||
|
||||
if (!inherits(p, "ggplot_build_gtable"))
|
||||
return(NULL)
|
||||
|
||||
tryCatch({
|
||||
# Get info from built ggplot object
|
||||
info <- find_panel_info(p$build)
|
||||
|
||||
# Get ranges from gtable - it's possible for this to return more elements than
|
||||
# info, because it calculates positions even for panels that aren't present.
|
||||
# This can happen with facet_wrap.
|
||||
ranges <- find_panel_ranges(p$gtable, pixelratio, res)
|
||||
|
||||
for (i in seq_along(info)) {
|
||||
info[[i]]$range <- ranges[[i]]
|
||||
}
|
||||
|
||||
return(info)
|
||||
|
||||
}, error = function(e) {
|
||||
# If there was an error extracting info from the ggplot object, just return
|
||||
# a list with the error message.
|
||||
return(structure(list(), error = e$message))
|
||||
})
|
||||
}
|
||||
|
||||
|
||||
find_panel_info <- function(b) {
|
||||
# Structure of ggplot objects changed after 2.1.0. After 2.2.1, there was a
|
||||
# an API for extracting the necessary information.
|
||||
ggplot_ver <- utils::packageVersion("ggplot2")
|
||||
|
||||
if (ggplot_ver > "2.2.1") {
|
||||
find_panel_info_api(b)
|
||||
} else if (ggplot_ver > "2.1.0") {
|
||||
find_panel_info_non_api(b, ggplot_format = "new")
|
||||
} else {
|
||||
find_panel_info_non_api(b, ggplot_format = "old")
|
||||
}
|
||||
}
|
||||
|
||||
# This is for ggplot2>2.2.1, after an API was introduced for extracting
|
||||
# information about the plot object.
|
||||
find_panel_info_api <- function(b) {
|
||||
# Given a built ggplot object, return x and y domains (data space coords) for
|
||||
# each panel.
|
||||
find_panel_info <- function(b) {
|
||||
layout <- ggplot2::summarise_layout(b)
|
||||
coord <- ggplot2::summarise_coord(b)
|
||||
layers <- ggplot2::summarise_layers(b)
|
||||
|
||||
if (ggplot_format == "api") {
|
||||
layout <- ggplot2::summarise_layout(b)
|
||||
coord <- ggplot2::summarise_coord(b)
|
||||
layers <- ggplot2::summarise_layers(b)
|
||||
|
||||
# Given x and y scale objects and a coord object, return a list that has
|
||||
# the bases of log transformations for x and y, or NULL if it's not a
|
||||
# log transform.
|
||||
get_log_bases <- function(xscale, yscale, coord) {
|
||||
# Given a transform object, find the log base; if the transform object is
|
||||
# NULL, or if it's not a log transform, return NA.
|
||||
get_log_base <- function(trans) {
|
||||
if (!is.null(trans) && grepl("^log-", trans$name)) {
|
||||
environment(trans$transform)$base
|
||||
} else {
|
||||
NA_real_
|
||||
}
|
||||
}
|
||||
|
||||
# First look for log base in scale, then coord; otherwise NULL.
|
||||
list(
|
||||
x = get_log_base(xscale$trans) %OR% coord$xlog %OR% NULL,
|
||||
y = get_log_base(yscale$trans) %OR% coord$ylog %OR% NULL
|
||||
)
|
||||
}
|
||||
|
||||
# Given x/y min/max, and the x/y scale objects, create a list that
|
||||
# represents the domain. Note that the x/y min/max should be taken from
|
||||
# the layout summary table, not the scale objects.
|
||||
get_domain <- function(xmin, xmax, ymin, ymax, xscale, yscale) {
|
||||
is_reverse <- function(scale) {
|
||||
identical(scale$trans$name, "reverse")
|
||||
}
|
||||
|
||||
domain <- list(
|
||||
left = xmin,
|
||||
right = xmax,
|
||||
bottom = ymin,
|
||||
top = ymax
|
||||
)
|
||||
|
||||
if (is_reverse(xscale)) {
|
||||
domain$left <- -domain$left
|
||||
domain$right <- -domain$right
|
||||
}
|
||||
if (is_reverse(yscale)) {
|
||||
domain$top <- -domain$top
|
||||
domain$bottom <- -domain$bottom
|
||||
}
|
||||
|
||||
domain
|
||||
}
|
||||
|
||||
# Rename the items in vars to have names like panelvar1, panelvar2.
|
||||
rename_panel_vars <- function(vars) {
|
||||
for (i in seq_along(vars)) {
|
||||
names(vars)[i] <- paste0("panelvar", i)
|
||||
}
|
||||
vars
|
||||
}
|
||||
|
||||
get_mappings <- function(layers, layout, coord) {
|
||||
# For simplicity, we'll just use the mapping from the first layer of the
|
||||
# ggplot object. The original uses quoted expressions; convert to
|
||||
# character.
|
||||
mapping <- layers$mapping[[1]]
|
||||
# lapply'ing as.character results in unexpected behavior for expressions
|
||||
# like `wt/2`; deparse handles it correctly.
|
||||
mapping <- lapply(mapping, deparse)
|
||||
|
||||
# If either x or y is not present, give it a NULL entry.
|
||||
mapping <- mergeVectors(list(x = NULL, y = NULL), mapping)
|
||||
|
||||
# The names (not values) of panel vars are the same across all panels,
|
||||
# so just look at the first one. Also, the order of panel vars needs
|
||||
# to be reversed.
|
||||
vars <- rev(layout$vars[[1]])
|
||||
for (i in seq_along(vars)) {
|
||||
mapping[[paste0("panelvar", i)]] <- names(vars)[i]
|
||||
}
|
||||
|
||||
if (isTRUE(coord$flip)) {
|
||||
mapping[c("x", "y")] <- mapping[c("y", "x")]
|
||||
}
|
||||
|
||||
mapping
|
||||
}
|
||||
|
||||
# Mapping is constant across all panels, so get it here and reuse later.
|
||||
mapping <- get_mappings(layers, layout, coord)
|
||||
|
||||
# If coord_flip is used, these need to be swapped
|
||||
flip_xy <- function(layout) {
|
||||
l <- layout
|
||||
l$xscale <- layout$yscale
|
||||
l$yscale <- layout$xscale
|
||||
l$xmin <- layout$ymin
|
||||
l$xmax <- layout$ymax
|
||||
l$ymin <- layout$xmin
|
||||
l$ymax <- layout$xmax
|
||||
l
|
||||
}
|
||||
if (coord$flip) {
|
||||
layout <- flip_xy(layout)
|
||||
}
|
||||
|
||||
# Iterate over each row in the layout data frame
|
||||
lapply(seq_len(nrow(layout)), function(i) {
|
||||
# Slice out one row, use it as a list. The (former) list-cols are still
|
||||
# in lists, so we need to unwrap them.
|
||||
l <- as.list(layout[i, ])
|
||||
l$vars <- l$vars[[1]]
|
||||
l$xscale <- l$xscale[[1]]
|
||||
l$yscale <- l$yscale[[1]]
|
||||
|
||||
list(
|
||||
panel = as.numeric(l$panel),
|
||||
row = l$row,
|
||||
col = l$col,
|
||||
# Rename panel vars. They must also be in reversed order.
|
||||
panel_vars = rename_panel_vars(rev(l$vars)),
|
||||
log = get_log_bases(l$xscale, l$yscale, coord),
|
||||
domain = get_domain(l$xmin, l$xmax, l$ymin, l$ymax, l$xscale, l$yscale),
|
||||
mapping = mapping
|
||||
)
|
||||
})
|
||||
|
||||
} else {
|
||||
|
||||
if (ggplot_format == "new") {
|
||||
layout <- b$layout$panel_layout
|
||||
# Given x and y scale objects and a coord object, return a list that has
|
||||
# the bases of log transformations for x and y, or NULL if it's not a
|
||||
# log transform.
|
||||
get_log_bases <- function(xscale, yscale, coord) {
|
||||
# Given a transform object, find the log base; if the transform object is
|
||||
# NULL, or if it's not a log transform, return NA.
|
||||
get_log_base <- function(trans) {
|
||||
if (!is.null(trans) && grepl("^log-", trans$name)) {
|
||||
environment(trans$transform)$base
|
||||
} else {
|
||||
layout <- b$panel$layout
|
||||
NA_real_
|
||||
}
|
||||
# Convert factor to numbers
|
||||
layout$PANEL <- as.integer(as.character(layout$PANEL))
|
||||
|
||||
# Names of facets
|
||||
facet_vars <- NULL
|
||||
if (ggplot_format == "new") {
|
||||
facet <- b$layout$facet
|
||||
if (inherits(facet, "FacetGrid")) {
|
||||
facet_vars <- vapply(c(facet$params$cols, facet$params$rows), as.character, character(1))
|
||||
} else if (inherits(facet, "FacetWrap")) {
|
||||
facet_vars <- vapply(facet$params$facets, as.character, character(1))
|
||||
}
|
||||
} else {
|
||||
facet <- b$plot$facet
|
||||
if (inherits(facet, "grid")) {
|
||||
facet_vars <- vapply(c(facet$cols, facet$rows), as.character, character(1))
|
||||
} else if (inherits(facet, "wrap")) {
|
||||
facet_vars <- vapply(facet$facets, as.character, character(1))
|
||||
}
|
||||
}
|
||||
|
||||
# Iterate over each row in the layout data frame
|
||||
lapply(seq_len(nrow(layout)), function(i) {
|
||||
# Slice out one row
|
||||
l <- layout[i, ]
|
||||
|
||||
scale_x <- l$SCALE_X
|
||||
scale_y <- l$SCALE_Y
|
||||
|
||||
mapping <- find_plot_mappings(b)
|
||||
|
||||
# For each of the faceting variables, get the value of that variable in
|
||||
# the current panel. Default to empty _named_ list so that it's sent as a
|
||||
# JSON object, not array.
|
||||
panel_vars <- list(a = NULL)[0]
|
||||
for (i in seq_along(facet_vars)) {
|
||||
var_name <- facet_vars[[i]]
|
||||
vname <- paste0("panelvar", i)
|
||||
|
||||
mapping[[vname]] <- var_name
|
||||
panel_vars[[vname]] <- l[[var_name]]
|
||||
}
|
||||
|
||||
list(
|
||||
panel = l$PANEL,
|
||||
row = l$ROW,
|
||||
col = l$COL,
|
||||
panel_vars = panel_vars,
|
||||
scale_x = scale_x,
|
||||
scale_y = scale_x,
|
||||
log = check_log_scales(b, scale_x, scale_y),
|
||||
domain = find_panel_domain(b, l$PANEL, scale_x, scale_y),
|
||||
mapping = mapping
|
||||
)
|
||||
})
|
||||
}
|
||||
|
||||
# First look for log base in scale, then coord; otherwise NULL.
|
||||
list(
|
||||
x = get_log_base(xscale$trans) %OR% coord$xlog %OR% NULL,
|
||||
y = get_log_base(yscale$trans) %OR% coord$ylog %OR% NULL
|
||||
)
|
||||
}
|
||||
|
||||
# Given x/y min/max, and the x/y scale objects, create a list that
|
||||
# represents the domain. Note that the x/y min/max should be taken from
|
||||
# the layout summary table, not the scale objects.
|
||||
get_domain <- function(xmin, xmax, ymin, ymax, xscale, yscale) {
|
||||
is_reverse <- function(scale) {
|
||||
identical(scale$trans$name, "reverse")
|
||||
}
|
||||
|
||||
domain <- list(
|
||||
left = xmin,
|
||||
right = xmax,
|
||||
bottom = ymin,
|
||||
top = ymax
|
||||
)
|
||||
|
||||
if (is_reverse(xscale)) {
|
||||
domain$left <- -domain$left
|
||||
domain$right <- -domain$right
|
||||
}
|
||||
if (is_reverse(yscale)) {
|
||||
domain$top <- -domain$top
|
||||
domain$bottom <- -domain$bottom
|
||||
}
|
||||
|
||||
domain
|
||||
}
|
||||
|
||||
# Rename the items in vars to have names like panelvar1, panelvar2.
|
||||
rename_panel_vars <- function(vars) {
|
||||
for (i in seq_along(vars)) {
|
||||
names(vars)[i] <- paste0("panelvar", i)
|
||||
}
|
||||
vars
|
||||
}
|
||||
|
||||
get_mappings <- function(layers, layout, coord) {
|
||||
# For simplicity, we'll just use the mapping from the first layer of the
|
||||
# ggplot object. The original uses quoted expressions; convert to
|
||||
# character.
|
||||
mapping <- layers$mapping[[1]]
|
||||
# lapply'ing as.character results in unexpected behavior for expressions
|
||||
# like `wt/2`; deparse handles it correctly.
|
||||
mapping <- lapply(mapping, deparse)
|
||||
|
||||
# If either x or y is not present, give it a NULL entry.
|
||||
mapping <- mergeVectors(list(x = NULL, y = NULL), mapping)
|
||||
|
||||
# The names (not values) of panel vars are the same across all panels,
|
||||
# so just look at the first one. Also, the order of panel vars needs
|
||||
# to be reversed.
|
||||
vars <- rev(layout$vars[[1]])
|
||||
for (i in seq_along(vars)) {
|
||||
mapping[[paste0("panelvar", i)]] <- names(vars)[i]
|
||||
}
|
||||
|
||||
if (isTRUE(coord$flip)) {
|
||||
mapping[c("x", "y")] <- mapping[c("y", "x")]
|
||||
}
|
||||
|
||||
mapping
|
||||
}
|
||||
|
||||
# Mapping is constant across all panels, so get it here and reuse later.
|
||||
mapping <- get_mappings(layers, layout, coord)
|
||||
|
||||
# If coord_flip is used, these need to be swapped
|
||||
flip_xy <- function(layout) {
|
||||
l <- layout
|
||||
l$xscale <- layout$yscale
|
||||
l$yscale <- layout$xscale
|
||||
l$xmin <- layout$ymin
|
||||
l$xmax <- layout$ymax
|
||||
l$ymin <- layout$xmin
|
||||
l$ymax <- layout$xmax
|
||||
l
|
||||
}
|
||||
if (coord$flip) {
|
||||
layout <- flip_xy(layout)
|
||||
}
|
||||
|
||||
# Iterate over each row in the layout data frame
|
||||
lapply(seq_len(nrow(layout)), function(i) {
|
||||
# Slice out one row, use it as a list. The (former) list-cols are still
|
||||
# in lists, so we need to unwrap them.
|
||||
l <- as.list(layout[i, ])
|
||||
l$vars <- l$vars[[1]]
|
||||
l$xscale <- l$xscale[[1]]
|
||||
l$yscale <- l$yscale[[1]]
|
||||
|
||||
list(
|
||||
panel = as.numeric(l$panel),
|
||||
row = l$row,
|
||||
col = l$col,
|
||||
# Rename panel vars. They must also be in reversed order.
|
||||
panel_vars = rename_panel_vars(rev(l$vars)),
|
||||
log = get_log_bases(l$xscale, l$yscale, coord),
|
||||
domain = get_domain(l$xmin, l$xmax, l$ymin, l$ymax, l$xscale, l$yscale),
|
||||
mapping = mapping
|
||||
)
|
||||
})
|
||||
}
|
||||
|
||||
|
||||
# This is for ggplot2<=2.2.1, before an API was introduced for extracting
|
||||
# information about the plot object. The "old" format was used before 2.1.0.
|
||||
# The "new" format was used after 2.1.0, up to 2.2.1. The reason these two
|
||||
# formats are mixed together in a single function is historical, and it's not
|
||||
# worthwhile to separate them at this point.
|
||||
find_panel_info_non_api <- function(b, ggplot_format) {
|
||||
# Given a single range object (representing the data domain) from a built
|
||||
# ggplot object, return the domain.
|
||||
find_panel_domain <- function(b, panel_num, scalex_num = 1, scaley_num = 1) {
|
||||
@@ -768,180 +737,220 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
|
||||
mappings
|
||||
}
|
||||
|
||||
# Given a gtable object, return the x and y ranges (in pixel dimensions)
|
||||
find_panel_ranges <- function(g, pixelratio) {
|
||||
# Given a vector of unit objects, return logical vector indicating which ones
|
||||
# are "null" units. These units use the remaining available width/height --
|
||||
# that is, the space not occupied by elements that have an absolute size.
|
||||
is_null_unit <- function(x) {
|
||||
# A vector of units can be either a list of individual units (a unit.list
|
||||
# object), each with their own set of attributes, or an atomic vector with
|
||||
# one set of attributes. ggplot2 switched from the former (in version
|
||||
# 1.0.1) to the latter. We need to make sure that we get the correct
|
||||
# result in both cases.
|
||||
if (inherits(x, "unit.list")) {
|
||||
# For ggplot2 <= 1.0.1
|
||||
vapply(x, FUN.VALUE = logical(1), function(u) {
|
||||
isTRUE(attr(u, "unit", exact = TRUE) == "null")
|
||||
})
|
||||
} else {
|
||||
# For later versions of ggplot2
|
||||
attr(x, "unit", exact = TRUE) == "null"
|
||||
}
|
||||
if (ggplot_format == "new") {
|
||||
layout <- b$layout$panel_layout
|
||||
} else {
|
||||
layout <- b$panel$layout
|
||||
}
|
||||
# Convert factor to numbers
|
||||
layout$PANEL <- as.integer(as.character(layout$PANEL))
|
||||
|
||||
# Names of facets
|
||||
facet_vars <- NULL
|
||||
if (ggplot_format == "new") {
|
||||
facet <- b$layout$facet
|
||||
if (inherits(facet, "FacetGrid")) {
|
||||
facet_vars <- vapply(c(facet$params$cols, facet$params$rows), as.character, character(1))
|
||||
} else if (inherits(facet, "FacetWrap")) {
|
||||
facet_vars <- vapply(facet$params$facets, as.character, character(1))
|
||||
}
|
||||
|
||||
# Workaround for a bug in the quartz device. If you have a 400x400 image and
|
||||
# run `convertWidth(unit(1, "npc"), "native")`, the result will depend on
|
||||
# res setting of the device. If res=72, then it returns 400 (as expected),
|
||||
# but if, e.g., res=96, it will return 300, which is incorrect.
|
||||
devScaleFactor <- 1
|
||||
if (grepl("quartz", names(grDevices::dev.cur()), fixed = TRUE)) {
|
||||
devScaleFactor <- res / 72
|
||||
} else {
|
||||
facet <- b$plot$facet
|
||||
if (inherits(facet, "grid")) {
|
||||
facet_vars <- vapply(c(facet$cols, facet$rows), as.character, character(1))
|
||||
} else if (inherits(facet, "wrap")) {
|
||||
facet_vars <- vapply(facet$facets, as.character, character(1))
|
||||
}
|
||||
|
||||
# Convert a unit (or vector of units) to a numeric vector of pixel sizes
|
||||
h_px <- function(x) {
|
||||
devScaleFactor * grid::convertHeight(x, "native", valueOnly = TRUE)
|
||||
}
|
||||
w_px <- function(x) {
|
||||
devScaleFactor * grid::convertWidth(x, "native", valueOnly = TRUE)
|
||||
}
|
||||
|
||||
# Given a vector of relative sizes (in grid units), and a function for
|
||||
# converting grid units to numeric pixels, return a list with: known pixel
|
||||
# dimensions, scalable dimensions, and the overall space for the scalable
|
||||
# objects.
|
||||
find_size_info <- function(rel_sizes, unit_to_px) {
|
||||
# Total pixels (in height or width)
|
||||
total_px <- unit_to_px(grid::unit(1, "npc"))
|
||||
# Calculate size of all panel(s) together. Panels (and only panels) have
|
||||
# null size.
|
||||
null_idx <- is_null_unit(rel_sizes)
|
||||
|
||||
# All the absolute heights. At this point, null heights are 0. We need to
|
||||
# calculate them separately and add them in later.
|
||||
px_sizes <- unit_to_px(rel_sizes)
|
||||
# Mark the null heights as NA.
|
||||
px_sizes[null_idx] <- NA_real_
|
||||
|
||||
# The plotting panels all are 'null' units.
|
||||
null_sizes <- rep(NA_real_, length(rel_sizes))
|
||||
null_sizes[null_idx] <- as.numeric(rel_sizes[null_idx])
|
||||
|
||||
# Total size allocated for panels is the total image size minus absolute
|
||||
# (non-panel) elements.
|
||||
panel_px_total <- total_px - sum(px_sizes, na.rm = TRUE)
|
||||
|
||||
# Size of a 1null unit
|
||||
null_px <- abs(panel_px_total / sum(null_sizes, na.rm = TRUE))
|
||||
|
||||
# This returned list contains:
|
||||
# * px_sizes: A vector of known pixel dimensions. The values that were
|
||||
# null units will be assigned NA. The null units are ones that scale
|
||||
# when the plotting area is resized.
|
||||
# * null_sizes: A vector of the null units. All others will be assigned
|
||||
# NA. The null units often are 1, but they may be any value, especially
|
||||
# when using coord_fixed.
|
||||
# * null_px: The size (in pixels) of a 1null unit.
|
||||
# * null_px_scaled: The size (in pixels) of a 1null unit when scaled to
|
||||
# fit a smaller dimension (used for plots with coord_fixed).
|
||||
list(
|
||||
px_sizes = abs(px_sizes),
|
||||
null_sizes = null_sizes,
|
||||
null_px = null_px,
|
||||
null_px_scaled = null_px
|
||||
)
|
||||
}
|
||||
|
||||
# Given a size_info, return absolute pixel positions
|
||||
size_info_to_px <- function(info) {
|
||||
px_sizes <- info$px_sizes
|
||||
|
||||
null_idx <- !is.na(info$null_sizes)
|
||||
px_sizes[null_idx] <- info$null_sizes[null_idx] * info$null_px_scaled
|
||||
|
||||
# If this direction is scaled down because of coord_fixed, we need to add an
|
||||
# offset so that the pixel locations are centered.
|
||||
offset <- (info$null_px - info$null_px_scaled) *
|
||||
sum(info$null_sizes, na.rm = TRUE) / 2
|
||||
|
||||
# Get absolute pixel positions
|
||||
cumsum(px_sizes) + offset
|
||||
}
|
||||
|
||||
heights_info <- find_size_info(g$heights, h_px)
|
||||
widths_info <- find_size_info(g$widths, w_px)
|
||||
|
||||
if (g$respect) {
|
||||
# This is a plot with coord_fixed. The grid 'respect' option means to use
|
||||
# the same pixel value for 1null, for width and height. We want the
|
||||
# smaller of the two values -- that's what makes the plot fit in the
|
||||
# viewport.
|
||||
null_px_min <- min(heights_info$null_px, widths_info$null_px)
|
||||
heights_info$null_px_scaled <- null_px_min
|
||||
widths_info$null_px_scaled <- null_px_min
|
||||
}
|
||||
|
||||
# Convert to absolute pixel positions
|
||||
y_pos <- size_info_to_px(heights_info)
|
||||
x_pos <- size_info_to_px(widths_info)
|
||||
|
||||
# Match up the pixel dimensions to panels
|
||||
layout <- g$layout
|
||||
# For panels:
|
||||
# * For facet_wrap, they'll be named "panel-1", "panel-2", etc.
|
||||
# * For no facet or facet_grid, they'll just be named "panel". For
|
||||
# facet_grid, we need to re-order the layout table. Assume that panel
|
||||
# numbers go from left to right, then next row.
|
||||
# Assign a number to each panel, corresponding to PANEl in the built ggplot
|
||||
# object.
|
||||
layout <- layout[grepl("^panel", layout$name), ]
|
||||
layout <- layout[order(layout$t, layout$l), ]
|
||||
layout$panel <- seq_len(nrow(layout))
|
||||
|
||||
# When using a HiDPI client on a Linux server, the pixel
|
||||
# dimensions are doubled, so we have to divide the dimensions by
|
||||
# `pixelratio`. When a HiDPI client is used on a Mac server (with
|
||||
# the quartz device), the pixel dimensions _aren't_ doubled, even though
|
||||
# the image has double size. In the latter case we don't have to scale the
|
||||
# numbers down.
|
||||
pix_ratio <- 1
|
||||
if (!grepl("^quartz", names(grDevices::dev.cur()))) {
|
||||
pix_ratio <- pixelratio
|
||||
}
|
||||
|
||||
# Return list of lists, where each inner list has left, right, top, bottom
|
||||
# values for a panel
|
||||
lapply(seq_len(nrow(layout)), function(i) {
|
||||
p <- layout[i, , drop = FALSE]
|
||||
list(
|
||||
left = x_pos[p$l - 1] / pix_ratio,
|
||||
right = x_pos[p$r] / pix_ratio,
|
||||
bottom = y_pos[p$b] / pix_ratio,
|
||||
top = y_pos[p$t - 1] / pix_ratio
|
||||
)
|
||||
})
|
||||
}
|
||||
|
||||
# Iterate over each row in the layout data frame
|
||||
lapply(seq_len(nrow(layout)), function(i) {
|
||||
# Slice out one row
|
||||
l <- layout[i, ]
|
||||
|
||||
tryCatch({
|
||||
# Get info from built ggplot object
|
||||
info <- find_panel_info(p$build)
|
||||
scale_x <- l$SCALE_X
|
||||
scale_y <- l$SCALE_Y
|
||||
|
||||
# Get ranges from gtable - it's possible for this to return more elements than
|
||||
# info, because it calculates positions even for panels that aren't present.
|
||||
# This can happen with facet_wrap.
|
||||
ranges <- find_panel_ranges(p$gtable, pixelratio)
|
||||
mapping <- find_plot_mappings(b)
|
||||
|
||||
for (i in seq_along(info)) {
|
||||
info[[i]]$range <- ranges[[i]]
|
||||
# For each of the faceting variables, get the value of that variable in
|
||||
# the current panel. Default to empty _named_ list so that it's sent as a
|
||||
# JSON object, not array.
|
||||
panel_vars <- list(a = NULL)[0]
|
||||
for (i in seq_along(facet_vars)) {
|
||||
var_name <- facet_vars[[i]]
|
||||
vname <- paste0("panelvar", i)
|
||||
|
||||
mapping[[vname]] <- var_name
|
||||
panel_vars[[vname]] <- l[[var_name]]
|
||||
}
|
||||
|
||||
return(info)
|
||||
|
||||
}, error = function(e) {
|
||||
# If there was an error extracting info from the ggplot object, just return
|
||||
# a list with the error message.
|
||||
return(structure(list(), error = e$message))
|
||||
list(
|
||||
panel = l$PANEL,
|
||||
row = l$ROW,
|
||||
col = l$COL,
|
||||
panel_vars = panel_vars,
|
||||
scale_x = scale_x,
|
||||
scale_y = scale_x,
|
||||
log = check_log_scales(b, scale_x, scale_y),
|
||||
domain = find_panel_domain(b, l$PANEL, scale_x, scale_y),
|
||||
mapping = mapping
|
||||
)
|
||||
})
|
||||
}
|
||||
|
||||
|
||||
# Given a gtable object, return the x and y ranges (in pixel dimensions)
|
||||
find_panel_ranges <- function(g, pixelratio, res) {
|
||||
# Given a vector of unit objects, return logical vector indicating which ones
|
||||
# are "null" units. These units use the remaining available width/height --
|
||||
# that is, the space not occupied by elements that have an absolute size.
|
||||
is_null_unit <- function(x) {
|
||||
# A vector of units can be either a list of individual units (a unit.list
|
||||
# object), each with their own set of attributes, or an atomic vector with
|
||||
# one set of attributes. ggplot2 switched from the former (in version
|
||||
# 1.0.1) to the latter. We need to make sure that we get the correct
|
||||
# result in both cases.
|
||||
if (inherits(x, "unit.list")) {
|
||||
# For ggplot2 <= 1.0.1
|
||||
vapply(x, FUN.VALUE = logical(1), function(u) {
|
||||
isTRUE(attr(u, "unit", exact = TRUE) == "null")
|
||||
})
|
||||
} else {
|
||||
# For later versions of ggplot2
|
||||
attr(x, "unit", exact = TRUE) == "null"
|
||||
}
|
||||
}
|
||||
|
||||
# Workaround for a bug in the quartz device. If you have a 400x400 image and
|
||||
# run `convertWidth(unit(1, "npc"), "native")`, the result will depend on
|
||||
# res setting of the device. If res=72, then it returns 400 (as expected),
|
||||
# but if, e.g., res=96, it will return 300, which is incorrect.
|
||||
devScaleFactor <- 1
|
||||
if (grepl("quartz", names(grDevices::dev.cur()), fixed = TRUE)) {
|
||||
devScaleFactor <- res / 72
|
||||
}
|
||||
|
||||
# Convert a unit (or vector of units) to a numeric vector of pixel sizes
|
||||
h_px <- function(x) {
|
||||
devScaleFactor * grid::convertHeight(x, "native", valueOnly = TRUE)
|
||||
}
|
||||
w_px <- function(x) {
|
||||
devScaleFactor * grid::convertWidth(x, "native", valueOnly = TRUE)
|
||||
}
|
||||
|
||||
# Given a vector of relative sizes (in grid units), and a function for
|
||||
# converting grid units to numeric pixels, return a list with: known pixel
|
||||
# dimensions, scalable dimensions, and the overall space for the scalable
|
||||
# objects.
|
||||
find_size_info <- function(rel_sizes, unit_to_px) {
|
||||
# Total pixels (in height or width)
|
||||
total_px <- unit_to_px(grid::unit(1, "npc"))
|
||||
# Calculate size of all panel(s) together. Panels (and only panels) have
|
||||
# null size.
|
||||
null_idx <- is_null_unit(rel_sizes)
|
||||
|
||||
# All the absolute heights. At this point, null heights are 0. We need to
|
||||
# calculate them separately and add them in later.
|
||||
px_sizes <- unit_to_px(rel_sizes)
|
||||
# Mark the null heights as NA.
|
||||
px_sizes[null_idx] <- NA_real_
|
||||
|
||||
# The plotting panels all are 'null' units.
|
||||
null_sizes <- rep(NA_real_, length(rel_sizes))
|
||||
null_sizes[null_idx] <- as.numeric(rel_sizes[null_idx])
|
||||
|
||||
# Total size allocated for panels is the total image size minus absolute
|
||||
# (non-panel) elements.
|
||||
panel_px_total <- total_px - sum(px_sizes, na.rm = TRUE)
|
||||
|
||||
# Size of a 1null unit
|
||||
null_px <- abs(panel_px_total / sum(null_sizes, na.rm = TRUE))
|
||||
|
||||
# This returned list contains:
|
||||
# * px_sizes: A vector of known pixel dimensions. The values that were
|
||||
# null units will be assigned NA. The null units are ones that scale
|
||||
# when the plotting area is resized.
|
||||
# * null_sizes: A vector of the null units. All others will be assigned
|
||||
# NA. The null units often are 1, but they may be any value, especially
|
||||
# when using coord_fixed.
|
||||
# * null_px: The size (in pixels) of a 1null unit.
|
||||
# * null_px_scaled: The size (in pixels) of a 1null unit when scaled to
|
||||
# fit a smaller dimension (used for plots with coord_fixed).
|
||||
list(
|
||||
px_sizes = abs(px_sizes),
|
||||
null_sizes = null_sizes,
|
||||
null_px = null_px,
|
||||
null_px_scaled = null_px
|
||||
)
|
||||
}
|
||||
|
||||
# Given a size_info, return absolute pixel positions
|
||||
size_info_to_px <- function(info) {
|
||||
px_sizes <- info$px_sizes
|
||||
|
||||
null_idx <- !is.na(info$null_sizes)
|
||||
px_sizes[null_idx] <- info$null_sizes[null_idx] * info$null_px_scaled
|
||||
|
||||
# If this direction is scaled down because of coord_fixed, we need to add an
|
||||
# offset so that the pixel locations are centered.
|
||||
offset <- (info$null_px - info$null_px_scaled) *
|
||||
sum(info$null_sizes, na.rm = TRUE) / 2
|
||||
|
||||
# Get absolute pixel positions
|
||||
cumsum(px_sizes) + offset
|
||||
}
|
||||
|
||||
heights_info <- find_size_info(g$heights, h_px)
|
||||
widths_info <- find_size_info(g$widths, w_px)
|
||||
|
||||
if (g$respect) {
|
||||
# This is a plot with coord_fixed. The grid 'respect' option means to use
|
||||
# the same pixel value for 1null, for width and height. We want the
|
||||
# smaller of the two values -- that's what makes the plot fit in the
|
||||
# viewport.
|
||||
null_px_min <- min(heights_info$null_px, widths_info$null_px)
|
||||
heights_info$null_px_scaled <- null_px_min
|
||||
widths_info$null_px_scaled <- null_px_min
|
||||
}
|
||||
|
||||
# Convert to absolute pixel positions
|
||||
y_pos <- size_info_to_px(heights_info)
|
||||
x_pos <- size_info_to_px(widths_info)
|
||||
|
||||
# Match up the pixel dimensions to panels
|
||||
layout <- g$layout
|
||||
# For panels:
|
||||
# * For facet_wrap, they'll be named "panel-1", "panel-2", etc.
|
||||
# * For no facet or facet_grid, they'll just be named "panel". For
|
||||
# facet_grid, we need to re-order the layout table. Assume that panel
|
||||
# numbers go from left to right, then next row.
|
||||
# Assign a number to each panel, corresponding to PANEl in the built ggplot
|
||||
# object.
|
||||
layout <- layout[grepl("^panel", layout$name), ]
|
||||
layout <- layout[order(layout$t, layout$l), ]
|
||||
layout$panel <- seq_len(nrow(layout))
|
||||
|
||||
# When using a HiDPI client on a Linux server, the pixel
|
||||
# dimensions are doubled, so we have to divide the dimensions by
|
||||
# `pixelratio`. When a HiDPI client is used on a Mac server (with
|
||||
# the quartz device), the pixel dimensions _aren't_ doubled, even though
|
||||
# the image has double size. In the latter case we don't have to scale the
|
||||
# numbers down.
|
||||
pix_ratio <- 1
|
||||
if (!grepl("^quartz", names(grDevices::dev.cur()))) {
|
||||
pix_ratio <- pixelratio
|
||||
}
|
||||
|
||||
# Return list of lists, where each inner list has left, right, top, bottom
|
||||
# values for a panel
|
||||
lapply(seq_len(nrow(layout)), function(i) {
|
||||
p <- layout[i, , drop = FALSE]
|
||||
list(
|
||||
left = x_pos[p$l - 1] / pix_ratio,
|
||||
right = x_pos[p$r] / pix_ratio,
|
||||
bottom = y_pos[p$b] / pix_ratio,
|
||||
top = y_pos[p$t - 1] / pix_ratio
|
||||
)
|
||||
})
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user