Nothing
### SCALES ###
.match.scale <- function(override, group, scales,
defaults = list(color = "black",
size = 1.0,
border = "black",
alpha = 1.0,
shape = 16),
type = c("color", "size", "border", "shape", "alpha")) {
type <- match.arg(type)
if (!is.null(override)) {
if (is.factor(override)) {
scales[[type]](override)
} else {
override
}
} else if (is.null(group)) {
defaults[[type]]
} else {
scales[[type]](group)
}
}
## Expands a range to incorporate new.data.
.jjplot.expand.range <- function(new.data, old.data) {
UseMethod(".jjplot.expand.range")
}
.jjplot.expand.range.default <- function(new.data, old.data) {
if (is.null(old.data) && is.null(new.data)) {
return(NULL)
} else {
range(c(old.data, new.data))
}
}
.jjplot.expand.range.factor <- function(new.data, old.data) {
if (is.null(old.data)) {
factor(levels(new.data), levels = levels(new.data))
} else {
stopifnot(levels(new.data)== levels(old.data))
old.data
}
}
.jjplot.expand.range.Date <- function(new.data, old.data) {
range(c(new.data, old.data))
}
jjplot.scale <- function(data, scale.params) {
UseMethod("jjplot.scale")
}
jjplot.scale.default <- function(data, scale.params) {
rr <- range(data)
pp <- pretty(rr)
scale.params$type <- match.arg(scale.params$type,
c("exact", "pretty"))
if (scale.params$type == "exact") {
if (rr[1] > pp[1]) {
pp[1] = rr[1]
}
if (rr[2] < pp[length(pp)]) {
pp[length(pp)] = rr[2]
}
}
list(pretty = pp,
labels = prettyNum(pp))
}
jjplot.scale.factor <- function(data, scale.params) {
stopifnot(!is.null(scale.params$factor.order))
list(pretty = 1:length(scale.params$factor.order),
labels = scale.params$factor.order)
}
jjplot.scale.Date <- function(data, scale.params) {
## FIXME:
## * Allow for user-specified formats
pp <- .pretty.POSIXlt(data)
list(pretty = as.numeric(pp),
labels = format(pp, format = "%Y/%m/%d"))
}
## print(foo <- .pretty.POSIXlt(as.Date(c("2007-01-05", "2010-05-12"))))
## print(foo <- .pretty.POSIXlt(as.Date(c("2007-01-05", "2007-05-12"))))
.diffdate <- function(a, b, units = c("days", "weeks", "hours", "mins", "secs",
"years", "months")) {
units <- match.arg(units)
if (units == "years") {
structure((as.POSIXlt(a)$year - as.POSIXlt(b)$year) +
(as.POSIXlt(a)$mon - as.POSIXlt(b)$mon) / 12,
units = "years")
} else if (units == "months") {
structure((as.POSIXlt(a)$year - as.POSIXlt(b)$year) * 12 +
(as.POSIXlt(a)$mon - as.POSIXlt(b)$mon),
units = "months")
} else {
difftime(a, b, units = units)
}
}
.seq.date <- function(from, to, by = 1,
units = c("weeks", "days", "hours",
"mins", "secs", "years", "months")) {
units <- match.arg(units)
if (units == "months") {
from.mon <- as.POSIXlt(from)$mon
from.year <- as.POSIXlt(from)$year
to.mon <- as.POSIXlt(to)$mon
to.year <- as.POSIXlt(to)$year
from.mon <- from.mon + from.year * 12
to.mon <- to.mon + to.year * 12
if (as.POSIXlt(to)$mday > 1) {
to.mon <- to.mon + 1
}
months <- seq(from.mon, to.mon, by = by)
as.Date(paste(months %/% 12 + 1900, (months %% 12) + 1, "01", sep = "-"))
} else if (units == "years") {
from.year <- as.POSIXlt(from)$year
to.year <- as.POSIXlt(to)$year
if (as.POSIXlt(to)$mday > 1 || as.POSIXlt(to)$mon > 0) {
to.year <- to.year + 1
}
years <- seq(from.year, to.year, by = by)
as.Date(paste(years + 1900, "01-01", sep = "-"))
} else {
stop("unsupported unit")
}
}
.pretty.POSIXlt <- function(dates,
ideal.num.breaks = 5,
upper.bound = 1.75,
lower.bount = 0.75) {
all.units <- c("weeks", "days", "hours", "mins", "secs", "years", "months")
date.range <- range(dates)
diffs <- lapply(all.units,
function(x) .diffdate(date.range[2], date.range[1], units = x))
jumps <- lapply(diffs, function(x) round(x / ideal.num.breaks))
jumps <- structure(unlist(jumps), names = all.units)
best.unit <- names(which.min(jumps[jumps > 0]))[1]
.seq.date(date.range[1], date.range[2], units = best.unit)
}
jjplot.scale.POSIXct <- function(data, scale.params) {
## See FIXME for jjplot.scale.Date.
pp <- pretty(range(data))
list(pretty = pp,
labels = format(as.POSIXct(pp, origin="1970-01-01")))
}
.make.color.scale <- function(cc, alpha, manual = NULL) {
if (is.null(cc) || length(cc) <= 1) {
function(z) { rgb(0, 0, 0, alpha) }
} else if (is.factor(cc)) {
colors <- hcl(h = seq(0, 360, length.out = nlevels(cc) + 1),
l = 75,
c = 55,
alpha = alpha)
colors <- colors[-length(colors)]
if (!is.null(manual)) {
colors <- manual
}
function(z) { colors[z] }
} else {
if (is.null(manual)) {
if (range(cc)[1] >= 0) {
cr <- colorRamp(c('white', 'blue'))
} else {
cr <- colorRamp(c('red', 'white', 'blue'))
}
} else {
cr <- manual
}
rr <- range(cc)
function(z) {
z[z > rr[2]] <- rr[2]
z[z < rr[1]] <- rr[1]
rgb(cr((z - rr[1]) / (rr[2] - rr[1])),
alpha = alpha * 255,
maxColorValue = 255)
}
}
}
.make.shape.scale <- function(cc) {
if (is.null(cc) || length(cc) <= 1) {
function(z) { 16 }
} else if (is.factor(cc)) {
shapes <- c(16, 15, 17, 18, 1, 0, 2, 3, 4, 5, 6)
if (nlevels(cc) > length(shapes)) {
stop("Too many levels for shape scale.")
}
function(z) { shapes[z] }
} else {
stop("Shape scales can only be used with factors!")
}
}
.make.size.scale <- function(ss) {
if (is.null(ss)) {
function(z) { 1.0 }
} else {
min.size <- 0.8
max.size <- 3.3
num.sizes <- 20
size.levels <- seq(sqrt(min.size), sqrt(max.size), length.out = num.sizes)^2
rr <- range(ss)
function(z) { size.levels[round((num.sizes - 1) * (z - rr[1]) / (rr[2] - rr[1])) + 1] }
}
}
.make.alpha.scale <- function(ss) {
if (is.null(ss)) {
function(z) { 1.0 }
} else {
num.alphas <- 10
size.levels <- sqrt(seq(0, 1, length.out = num.alphas))
rr <- range(ss)
function(z) { size.levels[round((num.alphas - 1) * (z - rr[1]) / (rr[2] - rr[1])) + 1] }
}
}
jjplot.theme.facet.x <- function(...) {
themes <- list(...)
function (x) {
themes[[x$facet.x]](...)
}
}
jjplot.theme.facet.y <- function(...) {
themes <- list(...)
function (x) {
themes[[x$facet.y]](...)
}
}
jjplot.theme.top.strip <- function(base.theme,
.levels) {
color.scale <- .make.color.scale(as.factor(.levels), 1.0)
function(.subset) {
theme <- base.theme(.subset)
theme$top.strip.color <-
color.scale(which(.levels == .subset$facet.x))
theme
}
}
jjplot.theme.right.strip <- function(base.theme,
.levels) {
color.scale <- .make.color.scale(as.factor(.levels), 1.0)
function(.subset) {
theme <- base.theme(.subset)
theme$right.strip.color <-
color.scale(which(.levels == .subset$facet.y))
theme
}
}
jjplot.theme <- function(theme = c("grey", "bw"),
...) {
themes <-
list(grey = list(grid.color = "white",
plot.background = "grey90",
plot.border = "white",
x.axis.color = "grey50",
y.axis.color = "grey50",
x.axis.title.color = "grey20",
y.axis.title.color = "grey20",
right.strip.color = "grey70",
top.strip.color = "grey70",
x.axis.angle = 0,
y.axis.angle = 0,
x.axis.type = "pretty",
y.axis.type = "pretty",
x.axis.labeler = I,
y.axis.labeler = I,
x.axis.expansion = 0.04,
y.axis.expansion = 0.04),
bw = list(grid.color = "grey90",
plot.background = "white",
plot.border = "black",
x.axis.color = "black",
y.axis.color = "black",
x.axis.title.color = "black",
y.axis.title.color = "black",
right.strip.color = "grey70",
top.strip.color = "grey70",
x.axis.angle = 0,
y.axis.angle = 0,
x.axis.type = "pretty",
y.axis.type = "pretty",
x.axis.labeler = I,
y.axis.labeler = I,
x.axis.expansion = 0.04,
y.axis.expansion = 0.04))
theme <- match.arg(theme)
theme <- themes[[theme]]
theme[names(list(...))] <- list(...)
function(...) {
theme
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.