### Copyright (C) 2001-2020 Deepayan Sarkar <Deepayan.Sarkar@R-project.org>
###
### This file is part of the lattice package for R.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
###
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE. See the GNU General Public License for more
### details.
###
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
### MA 02110-1301, USA
## overplot groups, but use default plot.* style rather than superpose.* style
panel.superpose.plain <-
function(..., col = NA, col.line = plot.line$col, col.symbol = plot.symbol$col,
pch = plot.symbol$pch, cex = plot.symbol$cex, fill = plot.symbol$fill,
font = plot.symbol$font, fontface = plot.symbol$fontface,
fontfamily = plot.symbol$fontfamily, lty = plot.line$lty,
lwd = plot.line$lwd, alpha = plot.symbol$alpha)
{
plot.line <- trellis.par.get("plot.line")
plot.symbol <- trellis.par.get("plot.symbol")
if (!missing(col)) {
if (missing(col.line))
col.line <- col
if (missing(col.symbol))
col.symbol <- col
}
panel.superpose(..., col.line = col.line, col.symbol = col.symbol,
pch = pch, cex = cex, fill = fill, font = font,
fontfamily = fontfamily, lty = lty, lwd = lwd, alpha = alpha)
}
xyplot.ts <-
function(x, data = NULL,
screens = if (superpose) 1 else colnames(x),
...,
superpose = FALSE, ## not used directly
cut = FALSE,
type = "l",
col = NULL,
lty = NULL,
lwd = NULL,
pch = NULL,
cex = NULL,
fill = NULL,
auto.key = superpose,
panel = if (superpose) "panel.superpose"
else "panel.superpose.plain",
par.settings = list(),
layout = NULL, as.table = TRUE,
xlab = "Time", ylab = NULL,
default.scales = list(y = list(relation =
if (missing(cut)) "free" else "same")))
{
ocall <- sys.call(); ocall[[1]] <- quote(xyplot)
## fix up some default settings;
## these are too obscure to put in as default arguments
if (NCOL(x) == 1) {
## only one series, so use the more standard "panel.superpose"
if (missing(superpose)) superpose <- TRUE
if (missing(auto.key)) auto.key <- FALSE
}
stopifnot(is.null(data))
timex <- time(x)
x <- as.matrix(x)
if (is.null(colnames(x)))
colnames(x) <- paste("V", seq_len(NCOL(x)), sep = "")
cn <- colnames(x)
## set up shingle for cut-and-stack plot
## (may not work well with irregular series)
time <- NULL
if (is.numeric(cut)) cut <- list(number = cut)
if (isTRUE(cut)) {
## calculate optimum aspect ratio using banking (as for aspect = "xy")
timediff <- diff(timex)
asp <- apply(x, 2, function(y)
banking(timediff, diff(y)) * diff(range(y)) / diff(range(timex))
)
asp <- median(asp)
## work out aspect ratio of n panels in vertical layout on a square
nasp <- 1 / (1:6)
## choose number of cuts so that the "xy" aspect matches layout
number <- which.min(abs(1 - (asp * 1:6) / nasp))
cut <- list(number = number)
if (number == 1) cut <- FALSE
}
if (is.list(cut))
{
ecargs <- list(x = timex)
ecargs <- modifyList(ecargs, cut)
time <- do.call(equal.count, ecargs)
default.scales <-
modifyList(list(x = list(relation = "sliced")),
default.scales)
}
## 'screens' defines which panels to draw series in
## if 'screens' was given as a readable value then always show strips
screensgiven <- !missing(screens) && !is.numeric(screens)
screens <- make.par.list(cn, screens, NROW(x), NCOL(x), 1)
screens <- unlist(screens, use.names = FALSE)
screens <- factor(screens, levels = unique(screens))
screens <- rep(screens, length.out = NCOL(x))
fac <- factor(rep(screens, each = NROW(x)))
## formula
tt <- rep(timex, NCOL(x))
fo <- if ((nlevels(fac) > 1) || screensgiven) {
if (!is.null(time))
x ~ tt | time * fac
else
x ~ tt | fac
} else {
if (!is.null(time))
x ~ tt | time
else
x ~ tt
}
if (is.null(layout)) {
npanels <- max(1, nlevels(fac)) * max(1, nlevels(time))
nc <- ceiling(npanels/6)
nr <- ceiling(npanels/nc)
layout <- c(nc, nr)
}
## set lines, not points, as default for key
if (is.logical(auto.key) && auto.key) auto.key <- list()
if (is.list(auto.key))
auto.key <-
modifyList(list(lines = TRUE, points = FALSE), auto.key)
## The original approach (e.g. in 0.18-4) was to update par.settings
## with the col, lty etc for each series, and let this be picked up by
## panel.superpose as well as auto.key.
##
## However, that causes problems: further drawing in the panels
## (e.g. with layer()) can appear to be broken because it uses the same
## par.settings, and this has a constant color for all superposed series
## by default.
##
## So now we avoid updating par.settings unless necessary for auto.key:
needStyles <-
(any(sapply(list(col, lty, lwd, pch, cex, fill), length) > 1))
## If all series are plotted in separate panels AND
## all have the same style, then we don't need 'groups'.
## (this avoids using spurious styles when 'panel' is overridden)
needGroups <-
((length(unique(screens)) < NCOL(x)) ||
(needStyles) ||
(is.list(type) && (length(type) > 1)))
if (needGroups)
groups <- factor(col(x), labels = cn)
else groups <- rep(factor(1), length(x))
if (is.list(type))
type <- make.par.list(cn, type, NROW(x), NCOL(x), "l")
## To make R CMD check happy
force(tt)
force(fo)
force(groups)
tmpcall <-
quote(xyplot(fo, groups = groups,
..., panel = panel,
type = type, distribute.type = is.list(type),
auto.key = auto.key, par.settings = par.settings,
layout = layout, as.table = as.table,
xlab = xlab, ylab = ylab,
default.scales = default.scales))
## Include style arguments (col, lty, etc) in the call only if specified.
## (Originally they were not, and were picked up only from par.settings)
if (length(par.settings) > 0) {
## apply settings here before we look up plot.line etc
opar <- trellis.par.get()
trellis.par.set(par.settings)
on.exit(trellis.par.set(opar))
}
plot.line <- trellis.par.get("plot.line")
plot.symbol <- trellis.par.get("plot.symbol")
unlistIfSimple <- function(z)
if (all(sapply(z, length) == 1)) unlist(z) else z
if (!is.null(col)) {
col <- make.par.list(cn, col, NROW(x), NCOL(x), plot.line$col)
tmpcall$col <- unlistIfSimple(col)
}
if (!is.null(lty)) {
lty <- make.par.list(cn, lty, NROW(x), NCOL(x), plot.line$lty)
tmpcall$lty <- unlistIfSimple(lty)
}
if (!is.null(lwd)) {
lwd <- make.par.list(cn, lwd, NROW(x), NCOL(x), plot.line$lwd)
tmpcall$lwd <- unlistIfSimple(lwd)
}
if (!is.null(pch)) {
pch <- make.par.list(cn, pch, NROW(x), NCOL(x), plot.symbol$pch)
tmpcall$pch <- unlistIfSimple(pch)
}
if (!is.null(cex)) {
cex <- make.par.list(cn, cex, NROW(x), NCOL(x), plot.symbol$cex)
tmpcall$cex <- unlistIfSimple(cex)
}
if (!is.null(fill)) {
fill <- make.par.list(cn, fill, NROW(x), NCOL(x), plot.symbol$fill)
tmpcall$fill <- unlistIfSimple(fill)
}
if (needStyles) {
## set 'superpose' styles to be picked up by auto.key
if (identical(panel, "panel.superpose.plain")) {
## (one alternative would be to define a new simplePlainKey(),
## but that would not work if the user called update(auto.key=))
if (is.null(col)) col <- plot.line$col
if (is.null(lty)) lty <- plot.line$lty
if (is.null(lwd)) lwd <- plot.line$lwd
if (is.null(pch)) pch <- plot.symbol$pch
if (is.null(cex)) cex <- plot.symbol$cex
if (is.null(fill)) fill <- plot.symbol$fill
}
if (!is.null(col)) {
par.settings <-
modifyList(list(superpose.line = list(col = unlist(col)),
superpose.symbol = list(col = unlist(col))),
par.settings)
}
if (!is.null(lty)) {
par.settings <-
modifyList(list(superpose.line = list(lty = unlist(lty))),
par.settings)
}
if (!is.null(lwd)) {
par.settings <-
modifyList(list(superpose.line = list(lwd = unlist(lwd))),
par.settings)
}
if (!is.null(pch)) {
par.settings <-
modifyList(list(superpose.symbol = list(pch = unlist(pch))),
par.settings)
}
if (!is.null(cex)) {
par.settings <-
modifyList(list(superpose.symbol = list(cex = unlist(cex))),
par.settings)
}
if (!is.null(fill)) {
par.settings <-
modifyList(list(superpose.symbol = list(fill = unlist(fill))),
par.settings)
}
}
obj <- eval(tmpcall)
obj$call <- ocall
obj
}
## COPIED FROM ZOO
## http://r-forge.r-project.org/plugins/scmsvn/viewcvs.php/pkg/zoo/R/plot.zoo.R?rev=609&root=zoo&view=markup
make.par.list <- function(nams, x, n, m, def, recycle = sum(unnamed) > 0) {
## if nams are the names of our variables and x is a parameter
## specification such as list(a = c(1,2), c(3,4)) then
## create a new list which uses the named variables from x
## and assigns the unnamed in order. For the remaining variables
## assign them the default value if recycle = FALSE or recycle the
## unnamed variables if recycle = TRUE. The default value for
## recycle is TRUE if there is at least one unnamed variable
## in x and is false if there are only named variables in x.
## n is the length of the series and m is the total number of series
## It only needs to know whether m is 1 or greater than m.
## def is the default value used when recycle = FALSE
## recycle = TRUE means recycle unspecified values
## recycle = FALSE means replace values for unspecified series with def
## Within series recycling is done even if recycle=FALSE.
## Should we allow arbirary names in 1d case?
## if (m > 1) stopifnot(all(names(x) %in% c("", nams)))
if (!is.list(x)) x <- if (m == 1) list(x) else as.list(x)
y <- vector(mode = "list", length = length(nams))
names(y) <- nams
in.x <- nams %in% names(x)
unnamed <- if (is.null(names(x))) rep(TRUE, length(x)) else names(x) == ""
if (!recycle) y[] <- def
y[in.x] <- x[nams[in.x]]
if (recycle) {
stopifnot(sum(unnamed) > 0)
y[!in.x] <- rep(x[unnamed], length.out = sum(!in.x)) ## CHECK, this was: x[unnamed]
} else {
y[which(!in.x)[seq_len(sum(unnamed))]] <- x[unnamed]
}
lapply(y, function(y) if (length(y)==1) y else rep(y, length.out = n))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.