Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

190 lines (142 sloc) 4.826 kb
# Scales object encapsultes multiple scales.
# All input and output done with data.frames to facilitate
# multiple input and output variables
Scales <- proto(Scale, expr={
objname <- "scales"
.scales <- list()
# Should this scale produce a legend?
legend <- TRUE
n <- function(.) length(.$.scales)
add <- function(., scale) {
# Remove old scale if it exists
old <- .$find(scale$output())
.$.scales[old] <- NULL
# Add new scale
.$.scales <- append(.$.scales, scale)
}
clone <- function(.) {
s <- Scales$new()
s$add(lapply(.$.scales, function(x) x$clone()))
s
}
find <- function(., output) {
out <- sapply(.$.scales, function(x) any(output %in% x$output()))
if (length(out) == 0) return(logical(0))
out
}
get_scales <- function(., output, scales=FALSE) {
scale <- .$.scales[.$find(output)]
if (length(scale) == 0) return(Scales$new())
if (scales || length(scale) > 1) {
.$proto(.scales = scale)
} else {
scale[[1]]
}
}
has_scale <- function(., output) {
any(.$find(output))
}
get_trained_scales <- function(.) {
Filter(function(x) x$trained(), .$.scales)
}
legend_desc <- function(., theme) {
# Loop through all scales, creating a list of titles, and a list of keys
keys <- titles <- vector("list", .$n())
hash <- character(.$n())
for(i in seq_len(.$n())) {
scale <- .$.scales[[i]]
if (!scale$legend) next
if (is.null(scale$.domain) && is.null(scale$limits)) next
# Figure out legend title
output <- scale$output()
titles[[i]] <- scale$name %||% theme$labels[[output]]
key <- data.frame(
scale$output_breaks(), I(scale$labels()))
names(key) <- c(output, ".label")
keys[[i]] <- key
hash[i] <- digest(list(titles[[i]], key$.label))
}
empty <- sapply(titles, is.null)
list(titles = titles[!empty], keys = keys[!empty], hash = hash[!empty])
}
position_scales <- function(.) {
.$get_scales(c("x","y","z"), TRUE)
}
non_position_scales <- function(.) {
out <- setdiff(.$output(), c("x", "y", "z"))
.$get_scales(out, TRUE)
}
output <- function(.) {
sapply(.$.scales, function(scale) scale$output())
}
input <- function(.) {
sapply(.$.scales, function(scale) scale$input())
}
# Train scale from a data frame
train_df <- function(., df, drop = FALSE) {
if (empty(df)) return()
lapply(.$.scales, function(scale) {
scale$train_df(df, drop)
})
}
# Map values from a data.frame. Returns data.frame
map_df <- function(., df) {
if (length(.$.scales) == 0) return(df)
oldcols <- df[!(names(df) %in% .$input())]
mapped <- lapply(.$.scales, function(scale) scale$map_df(df))
mapped <- mapped[!sapply(mapped, empty)]
if (length(mapped) > 0) {
data.frame(mapped, oldcols)
} else {
oldcols
}
}
# Transform values to cardinal representation
transform_df <- function(., df) {
if (length(.$.scales) == 0) return(df)
if (empty(df)) return(data.frame())
transformed <- plyr::compact(lapply(.$.scales, function(scale) {
scale$transform_df(df)
}))
cunion(as.data.frame(transformed), df)
}
# Add default scales.
# Add default scales to a plot.
#
# Called during final construction to ensure that all aesthetics have
# a scale
add_defaults <- function(., data, aesthetics, env) {
if (is.null(aesthetics)) return()
names(aesthetics) <- plyr::laply(names(aesthetics), aes_to_scale)
new_aesthetics <- setdiff(names(aesthetics), .$input())
# No new aesthetics, so no new scales to add
if(is.null(new_aesthetics)) return()
# Determine variable type for each column -------------------------------
vartype <- function(x) {
if (inherits(x, "Date")) return("date")
if (inherits(x, "POSIXt")) return("datetime")
if (is.numeric(x)) return("continuous")
"discrete"
}
datacols <- tryapply(
aesthetics[new_aesthetics], eval,
envir=data, enclos=env
)
new_aesthetics <- intersect(new_aesthetics, names(datacols))
if (length(datacols) == 0) return()
vartypes <- sapply(datacols, vartype)
# Work out scale names
scale_name_type <- paste("scale", new_aesthetics, vartypes, sep="_")
for(i in 1:length(new_aesthetics)) {
if (exists(scale_name_type[i])) {
scale <- get(scale_name_type[i])()
.$add(scale)
}
}
}
pprint <- function(., newline=TRUE) {
clist <- function(x) paste(x, collapse=",")
cat("Scales: ", clist(.$input()), " -> ", clist(.$output()), sep="")
if (newline) cat("\n")
}
})
Jump to Line
Something went wrong with that request. Please try again.