R/grob-promise.r

In hadley/ggplot1: Before there was ggplot2

# 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
}