# Grob promise objects store the promise of an object to be evaluated
# when the plot is drawn.
#
# They have the following attributes:
#
# * name
# * data (complete, as generated by build_df)
# * parameters
#
# Can think about grob creation as a series of data frame transformations.
#
# Raw data
# | using build_df
# \/
# Data mapped to new names, defaults included
# | preprocess_all, preprocess, pre_name
# \/
# Data transformed to new dimesionality (optional, what scales operate on)
# |
# \/
# Transformation to aesthetics
# |
# \/
# Transformation to grobs
#
# Create a new grob promise object
#
# @keyword manip
# @keyword internal
grobPromise <- function(name, data, params, aesthetics) {
gp <- list(
name = name,
data = data,
params = params,
aesthetics = aesthetics)
class(gp) <- "grobPromise"
gp
}
# Preprocess
# Precprocess panel given data set using information in grobPromise
#
# @arguments grobPromise to preprocess
# @arguments
# @keyword manip
# @keyword internal
preprocess <- function(gp, data) {
if (is.list(data) && !is.data.frame(data)) data <- data[[1]]
name <- paste("pre", gp$name, sep="_")
if (!exists(name, mode="function")) return(data)
do.call(name, c(data=list(as.name("data")), gp$params))
}
# Preprocess all panels in grob promise
#
# @keyword manip
# @keyword internal
preprocess_all <- function(gp, plot) {
aesthetics <- defaults(gp$aesthetics, plot$aesthetics)
gp$data <- build_df(plot, gp$data, aesthetics)
data.matrix <- facet(gp, plot$formula, plot$margins)
apply(data.matrix, c(1,2), function(data) preprocess(gp, data))
}
# Make grobs
#
# @keyword manip
# @keyword internal
make_grobs <- function(x, data) {
if (is.list(data) && !is.data.frame(data)) data <- data[[1]]
name <- paste("grob", x$name, sep="_")
if (!exists(name, mode="function")) {
warning(paste("Grob function ", name, " does not exist", sep=""))
return()
}
do.call(name, c(aesthetics=list(as.name("data")), x$params))
}
# Make all grobs
#
# @keyword manip
# @keyword internal
make_all_grobs <- function(x, data) {
apply(data, c(1,2), function(data) make_grobs(x, data))
}
# Break up data into individual facets
#
# @keyword manip
# @keyword internal
facet <- function(x, formula, margins) {
if (isTRUE(all.equal(formula, ". ~ ."))) return(matrix(list(x$data)))
facets <- stamp(x$data, formula, force, margins=margins)
for(i in which(is.na(facets))) facets[[i]] <- data.frame()
facets
}
# Build data frame
# Build data frome for a plot with given data and ... (dots) arguments
#
# Depending on the arguments supplied to \code{\link{plot_add}} we need
# to stitch together a data frame using the defaults from plot\$defaults
# where the user hasn't explicitly specified otherwise.
#
# Arguments in dots are evaluated in the context of \code{data} so that
# column names can easily be references.
#
# Also makes sure that it contains all the columns required to correctly
# place the output into the row+column structure defined by the formula,
# by using \code{\link[reshape]{expand.grid.df}} to add in extra columns if needed.
#
# @arguments plot object
# @arguments data frame to use
# @arguments extra arguments supplied by user that should be used first
# @keyword hplot
# @keyword internal
build_df <- function(plot, data = plot$data, aesthetics=NULL) {
if (is.null(data)) data <- plot$data
if(!is.data.frame(data)) stop("data is not a data.frame")
eval.each <- function(dots) tryapply(dots, function(x) eval(x, data, parent.frame()))
aesthetics <- defaults(aesthetics, plot$defaults)
df <- data.frame(eval.each(aesthetics))
df <- cbind(df, data[,intersect(names(data), plot$conditions), drop=FALSE])
reshape::expand.grid.df(df, unique(plot$data[, setdiff(plot$conditions, names(df)), drop=FALSE]), unique=FALSE)
}
# Uneval
# Convert an unevaluted list to a list of unevaluated objects
#
# @arguments unevaluated list (create with substitute)
# @keyword manip
# @keyword internal
uneval <- function(x) {
if (length(x) == 1) return(list())
parts <- vector("list", length(x) - 1)
names(parts) <- names(x)[-1]
for(i in length(x):2) parts[[i-1]] <- x[[i]]
parts
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.