Nothing
panel.hexplom <-
function(...)
panel.hexbinplot(...)
hexplom <- function(x, data, ...)
{
UseMethod("hexplom")
}
hexplom.data.frame <-
function (x, data = NULL, ..., groups = NULL, subset = TRUE)
{
ocall <- sys.call(sys.parent())
ocall[[1]] <- quote(hexplom)
ccall <- match.call()
if (!is.null(ccall$data))
warning("explicit 'data' specification ignored")
ccall$data <- list(x = x, groups = groups, subset = subset)
ccall$x <- ~x
ccall$groups <- groups
ccall$subset <- subset
ccall[[1]] <- quote(hexbin::hexplom)
ans <- eval.parent(ccall)
ans$call <- ocall
ans
}
hexplom.matrix <-
function (x, data = NULL, ..., groups = NULL, subset = TRUE)
{
ocall <- sys.call(sys.parent())
ocall[[1]] <- quote(hexplom)
ccall <- match.call()
if (!is.null(ccall$data))
warning("explicit 'data' specification ignored")
ccall$data <- list(x = x, groups = groups, subset = subset)
ccall$x <- ~x
ccall$groups <- groups
ccall$subset <- subset
ccall[[1]] <- quote(hexbin::hexplom)
ans <- eval.parent(ccall)
ans$call <- ocall
ans
}
hexplom.formula <-
function(x, data = NULL, ...)
{
ocall <- sys.call(sys.parent())
ocall[[1]] <- quote(hexplom)
ccall <- match.call()
ccall[[1]] <- quote(lattice::splom)
if (is.null(ccall$panel)) ccall$panel <- panel.hexplom
ans <- eval.parent(ccall)
ans$call <- ocall
ans
}
old.hexplom.formula <-
function(x,
data = parent.frame(),
auto.key = FALSE,
aspect = 1,
between = list(x = 0.5, y = 0.5),
#panel = if (is.null(groups)) "panel.hexplom"
#else "panel.superpose",
panel = panel.hexplom,
prepanel = NULL,
scales = list(),
strip = TRUE,
groups = NULL,
xlab = "Scatter Plot Matrix",
xlim,
ylab = NULL,
ylim,
superpanel = "panel.pairs",
pscales = 5,
varnames,
drop.unused.levels = lattice.getOption("drop.unused.levels"),
...,
default.scales = list(draw = FALSE, relation = "same", axs = "i"),
subset = TRUE)
{
## dots <- eval(substitute(list(...)), data, parent.frame())
dots <- list(...)
#groups <- eval(substitute(groups), data, parent.frame())
if(!is.null(groups))stop("groups not implemented yet")
subset <- eval(substitute(subset), data, parent.frame())
## Step 1: Evaluate x, y, etc. and do some preprocessing
## right.name <- deparse(substitute(formula))
## formula <- eval(substitute(formula), data, parent.frame())
form <-
## if (inherits(formula, "formula"))
latticeParseFormula(x, data,
subset = subset, groups = groups,
multiple = FALSE,
outer = FALSE, subscripts = TRUE,
drop = drop.unused.levels)
## else {
## if (is.matrix(formula)) {
## list(left = NULL,
## right = as.data.frame(formula)[subset,],
## condition = NULL,
## left.name = "",
## right.name = right.name,
## groups = groups,
## subscr = seq(length = nrow(formula))[subset])
## }
## else if (is.data.frame(formula)) {
## list(left = NULL,
## right = formula[subset,],
## condition = NULL,
## left.name = "",
## right.name = right.name,
## groups = groups,
## subscr = seq(length = nrow(formula))[subset])
## }
## else stop("invalid formula")
## }
## We need to be careful with subscripts here. It HAS to be there,
## and it's to be used to index x, y, z (and not only groups,
## unlike in xyplot etc). This means we have to subset groups as
## well, which is about the only use for the subscripts calculated
## in latticeParseFormula, after which subscripts is regenerated
## as a straight sequence indexing the variables
if (!is.null(form$groups)) groups <- form$groups[form$subscr]
subscr <- seq(length = nrow(form$right))
if (!is.function(panel)) panel <- eval(panel)
if (!is.function(strip)) strip <- eval(strip)
prepanel <-
if (is.function(prepanel)) prepanel
else if (is.character(prepanel)) get(prepanel)
else eval(prepanel)
cond <- form$condition
number.of.cond <- length(cond)
x <- as.data.frame(form$right)
if (number.of.cond == 0) {
strip <- FALSE
cond <- list(as.factor(rep(1, nrow(x))))
number.of.cond <- 1
}
if (!missing(varnames)) colnames(x) <-
eval(substitute(varnames), data, parent.frame())
## create a skeleton trellis object with the
## less complicated components:
#foo <- do.call(lattice:::trellis.skeleton,
foo <- do.call(trellis.skeleton,
c(list(cond = cond,
aspect = aspect,
between = between,
panel = superpanel,
strip = strip,
xlab = xlab,
ylab = ylab,
xlab.default = "Scatter Plot Matrix"), dots))
dots <- foo$dots # arguments not processed by trellis.skeleton
foo <- foo$foo
foo$call <- match.call()
## Step 2: Compute scales.common (leaving out limits for now)
## FIXME: It is not very clear exactly what effect scales is
## supposed to have. Not much in Trellis (probably), but there are
## certain components which are definitely relevant, and certain
## others (like log) which can be used in innovative
## ways. However, I'm postponing all that to later, if at all
if (!is.list(scales)) scales <- list()
## some defaults for scales
# if (is.null(scales$draw)) scales$draw <- FALSE
# if (is.null(scales$relation)) scales$relation <- "same"
# if (is.null(scales$axs)) scales$axs <- "i"
scales <- updateList(default.scales, scales)
foo <- c(foo,
#do.call(lattice:::construct.scales, scales))
do.call(construct.scales, scales))
## Step 3: Decide if limits were specified in call:
have.xlim <- !missing(xlim)
if (!is.null(foo$x.scales$limit)) {
have.xlim <- TRUE
xlim <- foo$x.scales$limit
}
have.ylim <- !missing(ylim)
if (!is.null(foo$y.scales$limit)) {
have.ylim <- TRUE
ylim <- foo$y.scales$limit
}
## Step 4: Decide if log scales are being used (has to be NO):
have.xlog <- !is.logical(foo$x.scales$log) || foo$x.scales$log
have.ylog <- !is.logical(foo$y.scales$log) || foo$y.scales$log
## immaterial, since scales has no effect.
# if (have.xlog) {
# xlog <- foo$x.scales$log
# xbase <-
# if (is.logical(xlog)) 10
# else if (is.numeric(xlog)) xlog
# else if (xlog == "e") exp(1)
#
# x <- log(x, xbase)
# if (have.xlim) xlim <- log(xlim, xbase)
# }
# if (have.ylog) {
# ylog <- foo$y.scales$log
# ybase <-
# if (is.logical(ylog)) 10
# else if (is.numeric(ylog)) ylog
# else if (ylog == "e") exp(1)
#
# y <- log(y, ybase)
# if (have.ylim) ylim <- log(ylim, ybase)
# }
## Step 5: Process cond
cond.max.level <- unlist(lapply(cond, nlevels))
## id.na used only to see if any plotting is needed. Not used
## subsequently, unlike other functions
id.na <- FALSE
for (j in 1:ncol(x))
id.na <- id.na | is.na(x[,j])
for (var in cond)
id.na <- id.na | is.na(var)
if (!any(!id.na)) stop("nothing to draw")
## Nothing simpler ?
## Step 6: Evaluate layout, panel.args.common and panel.args
foo$panel.args.common <-
c(list(z = x,
panel = panel,
panel.subscripts = TRUE,
groups = groups, # xscales = foo$x.scales, yscales =foo$y.scales,
.aspect.ratio=aspect,
pscales = pscales),
dots)
nplots <- prod(cond.max.level)
if (nplots != prod(sapply(foo$condlevels, length))) stop("mismatch")
foo$panel.args <- vector(mode = "list", length = nplots)
cond.current.level <- rep(1, number.of.cond)
for (panel.number in seq(length = nplots))
{
##id <- !id.na WHY ?
for(i in 1:number.of.cond)
{
var <- cond[[i]]
id <- if (is.shingle(var))
((var >=
levels(var)[[cond.current.level[i]]][1])
& (var <=
levels(var)[[cond.current.level[i]]][2]))
else (as.numeric(var) == cond.current.level[i])
}
foo$panel.args[[panel.number]] <-
list(subscripts = subscr[id])
cond.current.level <-
#lattice:::cupdate(cond.current.level, cond.max.level)
cupdate(cond.current.level, cond.max.level)
}
#more.comp <- c(lattice:::limits.and.aspect(
more.comp <- c(limits.and.aspect(
lattice::prepanel.default.splom,
prepanel = prepanel,
have.xlim = have.xlim, xlim = xlim,
have.ylim = have.ylim, ylim = ylim,
x.relation = foo$x.scales$relation,
y.relation = foo$y.scales$relation,
panel.args.common = foo$panel.args.common,
panel.args = foo$panel.args,
aspect = aspect,
nplots = nplots,
x.axs = foo$x.scales$axs,
y.axs = foo$y.scales$axs),
#lattice::: cond.orders(foo))
cond.orders(foo))
foo[names(more.comp)] <- more.comp
if (is.null(foo$legend) && !is.null(groups) &&
(is.list(auto.key) || (is.logical(auto.key) && auto.key)))
{
foo$legend <-
list(list(fun = "drawSimpleKey",
args =
updateList(list(text = levels(as.factor(groups)),
points = TRUE,
rectangles = FALSE,
lines = FALSE),
if (is.list(auto.key)) auto.key else list())))
foo$legend[[1]]$x <- foo$legend[[1]]$args$x
foo$legend[[1]]$y <- foo$legend[[1]]$args$y
foo$legend[[1]]$corner <- foo$legend[[1]]$args$corner
names(foo$legend) <-
if (any(c("x", "y", "corner") %in% names(foo$legend[[1]]$args)))
"inside"
else
"top"
if (!is.null(foo$legend[[1]]$args$space))
names(foo$legend) <- foo$legend[[1]]$args$space
}
class(foo) <- "trellis"
foo
}
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.