Nothing
R/settings.R
In lattice: Trellis Graphics for R
Defines functions
simpleTheme
.defaultLatticePrefixStatus
.defaultLatticeStatus
lattice.getStatus
.defaultLatticeOptions
lattice.options
lattice.getOption
show.settings
lset
trellis.device
trellis.par.set
trellis.par.get
classic.theme
standard.theme
canonical.theme
custom_theme
makeShadePalette
lower.saturation
col.whitebg
Documented in
canonical.theme
classic.theme
col.whitebg
custom_theme
lattice.getOption
lattice.options
lset
makeShadePalette
show.settings
simpleTheme
standard.theme
trellis.device
trellis.par.get
trellis.par.set
### Copyright (C) 2001-2006 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
col.whitebg <- function()
list(background = list(col="transparent"),
plot.polygon = list(col="#c8ffc8"),
box.rectangle = list(col="darkgreen"),
box.umbrella = list(col="darkgreen"),
dot.line = list(col="gray90"),
dot.symbol = list(col="darkgreen"),
plot.line = list(col="darkgreen"),
plot.symbol = list(col="darkgreen"),
##regions=list(col=rev(hsv(h=250:349/1000, v=30:129/150,s=.5,
##gamma = .6)))
regions = list(col = heat.colors(100)),
strip.shingle = list(col = c("#ff7f00", "#00ff00", "#00ffff",
"#0080ff", "#ff00ff", "#ff0000", "#ffff00")),
strip.background = list(col = c("#ffe5cc", "#ccffcc", "#ccffff",
"#cce6ff", "#ffccff", "#ffcccc", "#ffffcc")),
reference.line = list(col="gray90"),
superpose.line = list(col = c("darkgreen","red","royalblue",
"brown","orange","turquoise", "orchid"),
lty = 1:7),
superpose.symbol = list(pch = c(1,3,6,0,5,16,17), cex = rep(.7, 7),
col = c("darkgreen","red","royalblue",
"brown","orange","turquoise", "orchid")))
## this function is used to make the superpose.polygon colors less
## saturated versions of the symbol and line colors
lower.saturation <-
function(x, f = 0.2, space = c("RGB", "HCL"))
{
## lower saturation in RGB or HCL space?
space <- match.arg(tolower(space), c("rgb", "hcl"))
## for HCL space ideally colorspace::lighten() should be used
if((space == "hcl") && requireNamespace("colorspace")) {
return(colorspace::lighten(x, amount = 1 - f))
}
## for RGB space the old implementation from lattice is used,
## for HCL space (if colorspace is unavailable) an approximation in LUV is used
RGB <- col2rgb(x)
if(space == "rgb") {
RGB[] <- 255 - RGB
RGB[] <- round(f * RGB)
RGB[] <- 255 - RGB
} else {
## adjust L coordinate of HCL/LUV only, chroma is left as it is
LUV <- convertColor(t(RGB), from = "sRGB", to = "Luv", scale.in = 255)
Lold <- pmin(100, pmax(0, LUV[, "L"]))
LUV[, "L"] <- 100 - (100 - Lold) * f
RGB[] <- t(convertColor(LUV, from = "Luv", to = "sRGB", scale.out = 255))
}
rgb(RGB["red", ],
RGB["green", ],
RGB["blue", ],
maxColorValue = 255)
}
## make a 'shading' function from region colors, for use in
## wireframe(shade = TRUE). 'pref' controls the amount of matte /
## glossy-ness.
makeShadePalette <- function(col.regions, ..., min = 0.05, pref = 0.75)
{
cramp <- colorRamp(col.regions, ...)
function(irr, ref, height)
{
## All arguments will be scalars currently.
## Better alternative: use colorspace::darken()
RGB <- cramp(height)
RGB[] <- (min + (1-min) * irr * ref^pref) * RGB # darken
rgb(RGB[, 1], RGB[, 2], RGB[, 3], maxColorValue = 255)
}
}
## Construct a custom theme based on supplied colors (originally in
## latticeExtra).
custom_theme <-
function(symbol, fill, region,
reference = "gray90", bg = "transparent", fg = "black",
strip.bg = rep("gray95", 7), strip.fg = rep("gray70", 7),
...)
{
theme <-
list(plot.polygon = list(col = fill[1], border = fg[1]),
box.rectangle = list(col= symbol[1]),
box.umbrella = list(col= symbol[1]),
dot.line = list(col = reference),
dot.symbol = list(col = symbol[1]),
plot.line = list(col = symbol[1]),
plot.symbol = list(col= symbol[1]),
reference.line = list(col = reference),
superpose.line = list(col = symbol),
superpose.symbol = list(col = symbol),
superpose.polygon = list(col = fill, border = fg),
regions = list(col = colorRampPalette(region)(100)),
shade.colors = list(palette = makeShadePalette(region)),
strip.background = list(col = strip.bg),
strip.shingle = list(col = strip.fg),
strip.border = list(col = fg),
background = list(col = bg),
add.line = list(col = fg),
add.text = list(col = fg),
box.dot = list(col = fg),
axis.line = list(col = fg),
axis.text = list(col = fg),
strip.border = list(col = fg),
box.3d = list(col = fg),
par.xlab.text = list(col = fg),
par.ylab.text = list(col = fg),
par.zlab.text = list(col = fg),
par.main.text = list(col = fg),
par.sub.text = list(col = fg))
modifyList(modifyList(classic.theme("pdf"), theme),
simpleTheme(...))
}
## (v0.21-7) Extended to make it easy to provide user-supplied colors.
## Default symbol colors are from Okabe-Ito, reordered to match classic theme somewhat better.
## Default fill colors are lightened versions of the symbol colors.
## Default region colors are the sequential HCL palette "YlGnBu" (approximating the one from ColorBrewer).
## Old standard.theme() / canonical.theme() renamed to classic.theme()
canonical.theme <- function(...) standard.theme(...)
standard.theme <- function(name, color = TRUE,
symbol = palette.colors(palette = "Okabe-Ito")[c(6, 2, 4, 7, 3, 5, 8)],
fill = NULL,
region = hcl.colors(14, palette = "YlGnBu", rev = TRUE),
reference = "gray90",
bg = "transparent",
fg = "black",
...)
{
if (is.null(fill))
fill <- if (!missing(symbol)) lower.saturation(symbol, 0.4, space = "HCL")
else c("#94C6FF", "#FFD6AD", "#76E3B8", "#FFBBA9", "#BCE1FF", "#FFF691", "#FFC1E1")
if (!missing(name))
classic.theme(name = name, color = color)
else if (!color)
classic.theme(color = FALSE)
else
custom_theme(symbol = symbol, fill = fill, region = region,
reference = reference, bg = bg, fg = fg, ...)
}
classic.theme <- function(name = .Device, color = name != "postscript")
{
## For the purpose of this function, the only differences in the
## settings/themes arise from the difference in the default
## colors. So, I will first set up the appropriate colors
## according to 'name', and then use those to create the
## theme. The first 16 colors correspond to trellis.settings
## colors, the 17th is the background color.
if (color)
{
## color colors
can.col <-
if (name %in% c("windows", "X11"))
c("#000000", "#00ffff", "#ff00ff", "#00ff00",
"#ff7f00", "#007eff", "#ffff00", "#ff0000",
"#c6ffff", "#ffc3ff", "#c8ffc8", "#ffd18f",
"#a9e2ff", "#ffffc3", "#ff8c8a", "#aaaaaa",
"#909090")
else if (name %in% c("postscript", "pdf", "xfig"))
c("#000000", "#00ffff", "#ff00ff", "#00ff00",
"#ff7f00", "#0080ff", "#ffff00", "#ff0000",
"#ccffff", "#ffccff", "#ccffcc", "#ffe5cc",
"#cce6ff", "#ffffcc", "#ffcccc", "#e6e6e6",
"transparent")
else ## default, same as X11 for now
c("#000000", "#00FFFF", "#FF00FF", "#00FF00",
"#FF7F00", "#007EFF", "#FFFF00", "#FF0000",
"#C6FFFF", "#FFC3FF", "#C8FFC8", "#FFD18F",
"#A9E2FF", "#FFFFC3", "#FF8C8A", "#AAAAAA",
"#909090")
}
else ## b&w colors, same for all devices (8:15 mostly unnecessary)
can.col <-
c("#000000", "#999999", "#4C4C4C", "#E6E6E6", "#F2F2F2",
"#B2B2B2", "#000000", "#030303", "#050505", "#080808",
"#0A0A0A", "#0D0D0D", "#0F0F0F", "#121212", "#151515",
"#AAAAAA", "transparent")
## The following is the canonical definition of what elements are
## valid in any setting. Adding something here should be necessary
## and sufficient.
## Note: For any component with a $font entry, more general
## specifications using $fontfamily and $fontface is also allowed
## (see ?grid::gpar for details). If set, fontsize$text will
## override get.gpar("fontsize") (which in turn usually defaults
## to the device pointsize).
## color settings, modified later if postscript or color = FALSE
ans <-
list(grid.pars = list(), ## set globally at the beginning
fontsize = list(text = 12, points = 8),
background = list(alpha = 1, col = can.col[17]),
panel.background = list(col = "transparent"),
clip = list(panel = "on", strip = "on"),
add.line = list(alpha = 1, col = can.col[1], lty = 1, lwd = 1),
add.text = list(alpha = 1, cex = 1, col = can.col[1], font = 1, lineheight = 1.2),
plot.polygon = list(alpha = 1, col = can.col[2], border = "black", lty = 1, lwd = 1),
box.dot = list(alpha = 1, col = can.col[1], cex = 1, font = 1, pch = 16),
box.rectangle = list(alpha = 1, col = can.col[2], fill = "transparent", lty = 1, lwd = 1),
box.umbrella = list(alpha = 1, col = can.col[2], lty = 2, lwd = 1),
dot.line = list(alpha = 1, col = can.col[16], lty = 1, lwd = 1),
dot.symbol = list(alpha = 1, cex = 0.8, col = can.col[2], font = 1, pch = 16),
plot.line = list(alpha = 1, col = can.col[2], lty = 1, lwd = 1),
plot.symbol = list(alpha = 1, cex = 0.8, col = can.col[2], font = 1, pch = 1, fill = "transparent"),
reference.line = list(alpha = 1, col = can.col[16], lty = 1, lwd = 1),
strip.background = list(alpha = 1, col = can.col[c(12, 11, 9, 13, 10, 15, 14)]),
strip.shingle = list(alpha = 1, col = can.col[c(5, 4, 2, 6, 3, 8, 7)]),
strip.border = list(alpha = 1, col = rep(can.col[1], 7), lty = rep(1, 7), lwd = rep(1, 7)),
superpose.line = list(alpha = 1, col = can.col[2:8], lty = rep(1, 7), lwd = rep(1, 7)),
superpose.symbol = list(alpha = rep(1, 7), cex = rep(0.8, 7), col = can.col[2:8],
fill = lower.saturation(can.col[2:8]),
## WAS: fill = rep("transparent", 7),
font = rep(1, 7), pch = rep(1, 7)),
superpose.polygon= list(alpha = rep(1, 7),
col = lower.saturation(can.col[2:8]), ## WAS can.col[2:8]
border = rep("black", 7), lty = rep(1, 7), lwd = rep(1, 7)),
regions = list(alpha = 1, col = rev(cm.colors(100))),
shade.colors = list(alpha = 1, palette = function(irr, ref, height, saturation = .9) {
hsv(h = height, s = 1 - saturation * (1 - (1-ref)^0.5), v = irr)
}),
axis.line = list(alpha = 1, col = can.col[1], lty = 1, lwd = 1),
axis.text = list(alpha = 1, cex = .8, col = can.col[1], font = 1, lineheight = 1),
## NEW: controls widths of tick marks and padding of labels
axis.components = list(left = list(tck = 1, pad1 = 1, pad2 = 1),
top = list(tck = 1, pad1 = 1, pad2 = 1),
right = list(tck = 1, pad1 = 1, pad2 = 1),
bottom = list(tck = 1, pad1 = 1, pad2 = 1)),
## NEW: controls widths of basic layout's components
layout.heights = list(top.padding = 1,
main = 1,
main.key.padding = 1,
key.top = 1,
xlab.top = 1,
key.axis.padding = 1,
axis.top = 1,
strip = 1,
panel = 1, ## shouldn't be changed
axis.panel = 1, ## can be useful
between = 1,
axis.bottom = 1,
axis.xlab.padding = 1,
xlab = 1,
xlab.key.padding = 1,
key.bottom = 1,
key.sub.padding = 1,
sub = 1,
bottom.padding = 1),
layout.widths = list(left.padding = 1,
key.left = 1,
key.ylab.padding = 1,
ylab = 1,
ylab.axis.padding = 1,
axis.left = 1,
axis.panel = 1, ## can be useful
strip.left = 1,
panel = 1, ## shouldn't be changed
between = 1,
axis.right = 1,
axis.key.padding = 1,
ylab.right = 1,
key.right = 1,
right.padding = 1),
box.3d = list(alpha = 1, col = can.col[1], lty = 1, lwd = 1),
par.title.text = list(alpha = 1, cex = 1.2, col = can.col[1], font = 1, lineheight = 1), # legend title (not used for key yet)
par.xlab.text = list(alpha = 1, cex = 1, col = can.col[1], font = 1, lineheight = 1),
par.ylab.text = list(alpha = 1, cex = 1, col = can.col[1], font = 1, lineheight = 1),
par.zlab.text = list(alpha = 1, cex = 1, col = can.col[1], font = 1, lineheight = 1),
par.main.text = list(alpha = 1, cex = 1.2, col = can.col[1], font = 2, lineheight = 1),
par.sub.text = list(alpha = 1, cex = 1, col = can.col[1], font = 2, lineheight = 1))
if (color)
{
if (name == "postscript" || name == "pdf")
{
ans$plot.symbol$col <- can.col[6]
ans$plot.line$col <- can.col[6]
ans$dot.symbol$col <- can.col[6]
ans$box.rectangle$col <- can.col[6]
ans$box.umbrella$col <- can.col[6]
ans$superpose.symbol$col <- c(can.col[c(6, 3, 4, 8)],
"orange", "darkgreen", "brown")
ans$superpose.symbol$col[c(3, 6)] <- ans$superpose.symbol$col[c(6, 3)]
ans$superpose.line$col <- ans$superpose.symbol$col
}
}
else {
## black and white settings
ans$plot.polygon$col <- can.col[5]
### ans$box.dot$col <- can.col[1]
ans$box.rectangle$col <- can.col[1]
ans$box.umbrella$col <- can.col[1]
### ans$box.umbrella$lty <- 2
ans$dot.line$col <- can.col[4]
ans$dot.symbol$col <- can.col[1]
### ans$dot.symbol$cex <- 0.85
ans$plot.line$col <- can.col[1]
ans$plot.symbol$col <- can.col[1]
## changing this to be like barplot
## ans$regions$col <- gray(29:128/128)
ans$regions$col <- grey(seq(0.3^2.2, 0.9^2.2, length.out = 100)^(1/2.2))
ans$shade.colors$palette <-
function(irr, ref, height, w = .5)
grey(w * irr + (1 - w) * (1 - (1-ref)^.4))
### ans$reference.line$col <- can.col[4]
ans$strip.background$col <- can.col[rep(5, 7)]
ans$strip.shingle$col <- can.col[rep(6, 7)]
ans$superpose.line$col <- can.col[rep(1, 7)]
ans$superpose.line$lty <- 1:7
ans$superpose.symbol$col <- can.col[rep(1, 7)]
ans$superpose.symbol$cex <- rep(0.7, 7)
ans$superpose.symbol$pch <- c(1,3,6,0,5,16,17)
ans$superpose.polygon$col <- grey( (c(6, 12, 7, 11, 8, 10, 9)/15)^.8 )
##ans$superpose.symbol$pch <- c("o","+",">","s","w","#","{")
}
ans
}
## trellis.par.grep <-
## function(pattern,
## theme = trellis.par.get(),
## ...)
## {
## nms <- names(theme)
## id <- grep(pattern, nms)
## ## if match, leave in return value, o.w. apply recursively
## if (length(id)) id <- -id ## id now non-matches
## for (nm in nms[id])
## {
## print(nm)
## theme[[nm]] <-
## if (is.list(theme[[nm]]))
## trellis.par.grep(pattern, theme[[nm]], ...)
## else
## NULL
## }
## if (all(sapply(theme, is.null))) NULL else theme
## }
trellis.par.get <-
function(name = NULL)
{
## the default device is opened if none already open
if (is.null(dev.list())) trellis.device()
lattice.theme <- get("lattice.theme", envir = .LatticeEnv)
## just in case settings for the current device haven't been
## created yet, which may happen if the device is opened by x11(),
## say, (i.e., not by trellis.device()) and no trellis object has
## been printed on this device yet.
if (is.null(lattice.theme[[.Device]])) {
trellis.device(device = .Device, new = FALSE)
lattice.theme <- get("lattice.theme", envir = .LatticeEnv)
}
if (is.null(name))
lattice.theme[[.Device]]
else if (name %in% names(lattice.theme[[.Device]]))
lattice.theme[[.Device]][[name]]
else NULL
}
trellis.par.set <-
function(name, value, ..., theme, warn = TRUE, strict = FALSE)
{
## the default device is opened if none already open
if (is.null(dev.list()))
{
trellis.device()
if (warn)
warning("Note: The default device has been opened to honour attempt to modify trellis settings")
}
## if (name %in% names(lattice.theme[[.Device]])) NEEDED as a safeguard ?
## if (!is.list(value)) stop("value must be a list")
lattice.theme <- get("lattice.theme", envir = .LatticeEnv)
## make sure a list for this device is present
if (is.null(lattice.theme[[.Device]]))
{
trellis.device(device = .Device, new = FALSE)
lattice.theme <- get("lattice.theme", envir = .LatticeEnv)
}
## WAS: lattice.theme[[.Device]][[name]] <- value
if (missing(theme))
{
if (!missing(value))
{
theme <- list(value)
names(theme) <- name
}
else if (!missing(name) && is.list(name))
{
theme <- name
}
else theme <- list(...)
}
else
{
if (is.character(theme)) theme <- get(theme)
if (is.function(theme)) theme <- theme()
if (!is.list(theme))
{
warning("Invalid 'theme' specified")
theme <- NULL
}
}
if (strict)
{
if (strict > 1L) lattice.theme[[.Device]] <- theme
else lattice.theme[[.Device]][names(theme)] <- theme
}
else
lattice.theme[[.Device]] <- updateList(lattice.theme[[.Device]], theme)
assign("lattice.theme", lattice.theme, envir = .LatticeEnv)
invisible()
}
trellis.device <-
function(device = getOption("device"),
color = !(dev.name == "postscript"),
theme = lattice.getOption("default.theme"),
new = TRUE,
retain = FALSE,
...)
{
## Get device function
if (is.character(device))
{
## to make sure this works even if package grDevices is not attached
if (new || is.null(dev.list()))
{
device.call <- try(get(device), silent = TRUE)
if (inherits(device.call, "try-error"))
device.call <-
try(utils::getFromNamespace(device, "grDevices"),
silent = TRUE)
if (inherits(device.call, "try-error"))
stop(gettextf("Could not find device function '%s'", device))
}
dev.name <- device
}
else
{
device.call <- device
dev.name <- deparse(substitute(device))
}
## Start the new device if necessary.
## new = FALSE ignored if no devices open.
## FIXME: remove this warning in some future version
if ("bg" %in% names(list(...)))
warning("'trellis.device' has changed, 'bg' may not be doing what you think it is")
if (new || is.null(dev.list()))
{
device.call(...)
lattice.setStatus(print.more = FALSE)
}
## In the olden days, the defaults were device specific, and given
## by 'canonical.theme(name = .Device, color = color)'. From R
## 2.3.0, this was changed so that all (color) devices now have
## the same defaults, namely 'canonical.theme(name = "pdf", color
## = color)'. The old default can be reinstated by putting
## 'options(lattice.theme = "canonical.theme")' during startup, or
## 'lattice.options(default.theme = "canonical.theme")' after
## loading lattice.
## Update: From lattice 0.21, canonical.theme has been updated to
## use a HCL based color palette by default, and
## 'canonical.theme()' has been renamed to 'classic.theme()'.
## Make sure there's an entry for this device in the theme list
lattice.theme <- get("lattice.theme", envir = .LatticeEnv)
if (!(.Device %in% names(lattice.theme)))
{
lattice.theme[[.Device]] <- standard.theme(color = color)
assign("lattice.theme", lattice.theme, envir = .LatticeEnv)
}
## If retain = FALSE, overwrite with default settings for device
if (!retain) trellis.par.set(standard.theme(color = color))
## get theme as list
if (!is.null(theme) && !is.list(theme))
{
if (is.character(theme)) theme <- get(theme)
if (is.function(theme)) theme <- theme()
if (!is.list(theme))
{
warning("Invalid 'theme' specified")
theme <- NULL
}
}
## apply theme
if (!is.null(theme)) trellis.par.set(theme)
return(invisible())
}
lset <- function(theme = col.whitebg())
{
.Defunct("trellis.par.set")
}
show.settings <- function(x = NULL)
{
old.settings <- trellis.par.get()
on.exit(trellis.par.set(old.settings))
if (!is.null(x)) trellis.par.set(x)
theme <- trellis.par.get()
d <- c("superpose.symbol",
"superpose.line",
"strip.background",
"strip.shingle",
"dot.[symbol, line]",
"box.[dot, rectangle, umbrella]",
"add.[line, text]",
"reference.line",
"plot.[symbol, line]",
"plot.shingle[plot.polygon]",
"histogram[plot.polygon]",
"barchart[plot.polygon]",
"superpose.polygon",
"regions")
d <- factor(d, levels = d)
## We only draw a border box for some panels. To do this, we make
## axis.line globally transparent, and then draw the border on a
## case-by-case basis. But to do that, we need to store the
## original axis.line settings.
par.box <- trellis.par.get("axis.line")
panel.box <- function()
{
panel.fill(col = "transparent",
border = adjustcolor(par.box$col, par.box$alpha),
lty = par.box$lty,
lwd = par.box$lwd)
}
xyplot(d ~ d | d,
prepanel = function(x, y) {
list(ylim = c(0, 1),
xlim = as.character(x),
xat = 1)
},
panel = function(x, y) {
cpl <- current.panel.limits() # ylim = c(0, 1)
rsx <- function(u) # (ReScaleX) map from [0,1]
{
cpl$xlim[1] + u * diff(cpl$xlim)
}
switch(as.character(x),
"superpose.symbol" = {
superpose.symbol <- trellis.par.get("superpose.symbol")
len <- max(2, sapply(superpose.symbol, length))
panel.superpose(x = rep(rsx(ppoints(len)), len),
y = rep(ppoints(len), each = len),
groups = gl(len, len),
subscripts = 1:(len*len))
},
"superpose.line" = {
superpose.line <- trellis.par.get("superpose.line")
len <- max(2, sapply(superpose.line, length))
panel.superpose(x = rep(rsx(c(0,1)), len),
y = rep(ppoints(1:len), each = 2),
groups = gl(len, 2),
subscripts = 1:(2*len),
type = "l")
},
"strip.background" = {
strip.background <- trellis.par.get("strip.background")
strip.border <- trellis.par.get("strip.border")
len <-
max(2, sapply(strip.background, length),
sapply(strip.border, length))
panel.rect(y = ppoints(len), height = 0.5 / len,
xleft = cpl$xlim[1], xright = cpl$xlim[2],
col = adjustcolor(strip.background$col, strip.background$alpha),
border = strip.border$col,
lty = strip.border$lty,
lwd = strip.border$lwd)
},
"strip.shingle" = {
strip.shingle <- trellis.par.get("strip.shingle")
len <- max(2, sapply(strip.shingle, length))
panel.rect(y = ppoints(len), height = 0.5 / len,
xleft = cpl$xlim[1], xright = cpl$xlim[2],
col = adjustcolor(strip.shingle$col, strip.shingle$alpha),
border = "transparent")
},
"dot.[symbol, line]" = {
panel.dotplot(x = rsx(ppoints(5, a = 0)), y = ppoints(5, a = 0))
panel.box()
},
"box.[dot, rectangle, umbrella]" = {
panel.bwplot(x = rsx(ppoints(5)), y = rep(0.5, 5), box.width = 0.15)
panel.box()
},
"add.[line, text]" = {
add.line <- trellis.par.get("add.line")
xx <- seq(0.1, 0.9, length.out = 50)
yy <- 0.5 + .45 * sin(0.1 + 11 * xx)
panel.lines(x = rsx(xx), y = yy,
col = add.line$col, lty = add.line$lty, lwd = add.line$lwd)
panel.text(labels = c("Hello", "World"),
x = rsx(c(.25, .75)), y = c(0.25, 0.75))
panel.box()
},
"reference.line" = {
panel.grid()
panel.box()
},
"plot.[symbol, line]" = {
## plot.symbol <- trellis.par.get("plot.symbol")
## plot.line <- trellis.par.get("plot.line")
## x <- seq(.1, .9, length.out = 20)
## y <- .9 * sin(.1+11*x)
xx <- seq(0.1, 0.9, length.out = 20)
yy <- 0.5 + .4 * sin(0.1 + 11 * xx)
panel.xyplot(x = rsx(xx + 0.05), y = yy + 0.01, type = "l")
panel.xyplot(x = rsx(xx - 0.05), y = yy - 0.01)
panel.box()
},
"plot.shingle[plot.polygon]" = {
xx <- seq(0.1, 0.4, length.out = 5)
yy <- ppoints(5)
panel.barchart(x = rsx(xx + 0.5), y = yy, origin = rsx(xx),
reference = FALSE, horizontal = TRUE,
box.width = 1/10)
panel.box()
},
"histogram[plot.polygon]" = {
xx <- ppoints(7, 0)
panel.barchart(x = rsx(xx), y = (2:8)/9, horizontal = FALSE,
origin = 1/18, box.width = diff(rsx(xx))[1],
reference = FALSE)
panel.box()
},
"barchart[plot.polygon]" = {
xx <- ppoints(6)
panel.barchart(x = rev(rsx(xx)), y = xx,
origin = cpl$xlim[1], box.width = 1/12)
panel.box()
},
"superpose.polygon" = {
superpose.polygon <- trellis.par.get("superpose.polygon")
len <- max(2, sapply(superpose.polygon, length))
xx <- ppoints(len)
panel.barchart(x = rsx(rev(xx)), y = rep(0.5, len),
groups = gl(len, 1),
subscripts = seq_len(len),
stack = FALSE,
box.width = 0.9)
panel.box()
},
"regions" = {
panel.levelplot(x = do.breaks(cpl$xlim, 98),
y = rep(0.5, 99),
z = 1:99 + 0.5,
at = 1:100,
region = TRUE,
subscripts = 1:99)
panel.box()
})
},
## layout = c(4, 4),
par.settings = modifyList(theme,
list(axis.line = list(col = "transparent"),
clip = list(panel = "off"))),
as.table = TRUE, strip = FALSE, xlab = "", ylab = "",
between = list(x = 1, y = 0.5),
scales = list(relation = "free",
y = list(draw = FALSE, axs = "i"),
x = list(tck = 0, axs = "r")))
}
## show.settings.old <- function(x = NULL)
## {
## old.settings <- trellis.par.get()
## on.exit(trellis.par.set(old.settings))
## if (!is.null(x)) trellis.par.set(x)
## theme <- trellis.par.get()
## n.row <- 13
## n.col <- 9
## heights.x <- rep(1, n.row)
## heights.units <- rep("lines", n.row)
## heights.units[c(2, 5, 8, 11)] <- "null"
## widths.x <- rep(1, n.row)
## widths.units <- rep("lines", n.row)
## widths.units[c(2, 4, 6, 8)] <- "null"
## page.layout <-
## grid.layout(nrow = n.row, ncol = n.col,
## widths = unit(widths.x, widths.units),
## heights = unit(heights.x, heights.units))
## if (!lattice.getStatus("print.more")) grid.newpage()
## lattice.setStatus(print.more = FALSE)
## grid.rect(gp = gpar(fill = theme$background$col,
## col = "transparent"))
## pushViewport(viewport(layout = page.layout,
## gp = gpar(fontsize = theme$fontsize$text)))
## gp.box <-
## gpar(col = theme$axis.line$col,
## lty = theme$axis.line$lty,
## lwd = theme$axis.line$lwd,
## alpha = theme$axis.line$alpha,
## fill = "transparent")
## ## superpose.symbol
## superpose.symbol <- theme$superpose.symbol
## len <- max(2, sapply(superpose.symbol, length))
## pushViewport(viewport(layout.pos.row = 2,
## layout.pos.col = 2,
## yscale = c(0,len+1),
## xscale = c(0,len+1)))
## panel.superpose(x = rep(1:len, len),
## y = rep(1:len, each = len),
## groups = gl(len, len),
## subscripts = 1:(len*len))
## popViewport()
## grid.text(label = "superpose.symbol",
## vp = viewport(layout.pos.row = 3, layout.pos.col = 2))
## ## superpose.line
## superpose.line <- theme$superpose.line
## len <- max(2, sapply(superpose.line, length))
## pushViewport(viewport(layout.pos.row = 2,
## layout.pos.col = 4,
## yscale = c(0,len+1),
## xscale = c(0, 1)))
## panel.superpose(x = rep(c(0,1), len),
## y = rep(1:len, each = 2),
## groups = gl(len, 2),
## subscripts = 1:(2*len),
## type = "l")
## popViewport()
## grid.text(label = "superpose.line",
## vp = viewport(layout.pos.row = 3, layout.pos.col = 4))
## ## strip.background
## strip.background <- theme$strip.background
## strip.border <- theme$strip.border
## len <-
## max(sapply(strip.background, length),
## sapply(strip.border, length))
## pushViewport(viewport(layout.pos.row = 2,
## layout.pos.col = 6,
## yscale = c(0, len+1),
## xscale = c(0, 1)))
## grid.rect(y = unit(1:len, "native"),
## height = unit(0.5, "native"),
## gp =
## gpar(fill = strip.background$col,
## alpha = strip.background$alpha,
## col = strip.border$col,
## lty = strip.border$lty,
## lwd = strip.border$lwd))
## popViewport()
## grid.text(label = "strip.background",
## vp = viewport(layout.pos.row = 3, layout.pos.col = 6))
## ## strip.shingle
## strip.shingle <- theme$strip.shingle
## len <- max(sapply(strip.shingle, length))
## pushViewport(viewport(layout.pos.row = 2,
## layout.pos.col = 8,
## yscale = c(0,len+1),
## xscale = c(0,1)))
## grid.rect(y = unit(1:len, "native"),
## height = unit(0.5, "native"),
## gp =
## gpar(fill = strip.shingle$col,
## alpha = strip.shingle$alpha,
## col = "transparent", lwd = 0.0001))
## popViewport()
## grid.text(label = "strip.shingle",
## vp = viewport(layout.pos.row = 3, layout.pos.col = 8))
## ## dot.[symbol, line]
## pushViewport(viewport(layout.pos.row = 5,
## layout.pos.col = 2,
## yscale = extend.limits(c(0,6)),
## xscale = c(0,6)))
## panel.dotplot(x = 1:5, y = 1:5)
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "dot.[symbol, line]",
## vp = viewport(layout.pos.row = 6, layout.pos.col = 2))
## ## box.[dot, rectangle, umbrella]
## pushViewport(viewport(layout.pos.row = 5,
## layout.pos.col = 4,
## yscale = c(-2, 2),
## xscale = c(0,6)))
## panel.bwplot(x = 1:5, y = rep(0, 5))
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "box.[dot, rectangle, umbrella]",
## vp = viewport(layout.pos.row = 6, layout.pos.col = 4))
## ## add.[line, text]
## add.text <- theme$add.text
## add.line <- theme$add.line
## pushViewport(viewport(layout.pos.row = 5,
## layout.pos.col = 6,
## yscale = c(-1,1),
## xscale = c(0,1)))
## x <- seq(.1, .9, length.out = 50)
## y <- .9 * sin(.1+11*x)
## llines(x = x, y = y, type = "l", col = add.line$col,
## lty = add.line$lty, lwd = add.line$lwd)
## ltext(labels = c("Hello", "World"),
## x = c(.25, .75), y = c(-.5, .5))
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "add.[line, text]",
## vp = viewport(layout.pos.row = 6, layout.pos.col = 6))
## ## reference.line
## pushViewport(viewport(layout.pos.row = 5,
## layout.pos.col = 8,
## yscale = c(0,4),
## xscale = c(0,4)))
## panel.grid()
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "reference.line",
## vp = viewport(layout.pos.row = 6, layout.pos.col = 8))
## ## plot.[symbol, line]
## plot.symbol <- theme$plot.symbol
## plot.line <- theme$plot.line
## pushViewport(viewport(layout.pos.row = 8,
## layout.pos.col = 2,
## yscale = c(-1.1,1.1),
## xscale = c(-.1,1.1)))
## x <- seq(.1, .9, length.out = 20)
## y <- .9 * sin(.1+11*x)
## panel.xyplot(x = x+.05, y = y+.1, type = "l")
## panel.xyplot(x = x-.05, y = y-.1)
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "plot.[symbol, line]",
## vp = viewport(layout.pos.row = 9, layout.pos.col = 2))
## ## plot.shingle[plot.polygon]
## plot.polygon <- theme$plot.polygon
## pushViewport(viewport(layout.pos.row = 8,
## layout.pos.col = 4,
## yscale = extend.limits(c(0,6)),
## xscale = extend.limits(c(1,10))))
## grid.rect(x = c(3.5, 4.5, 5.5, 6.5, 7.5), width = rep(5,5),
## y = c(1,2,3,4,5), height = rep(.5, ,5),
## default.units = "native",
## gp =
## gpar(fill = plot.polygon$col,
## col = plot.polygon$border,
## alpha = plot.polygon$alpha,
## lty = plot.polygon$lty,
## lwd = plot.polygon$lwd))
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "plot.shingle[plot.polygon]",
## vp = viewport(layout.pos.row = 9, layout.pos.col = 4))
## ## histogram[plot.polygon]
## pushViewport(viewport(layout.pos.row = 8,
## layout.pos.col = 6,
## yscale = extend.limits(c(0,7)),
## xscale = extend.limits(c(0.5,7.5))))
## panel.histogram(x = rep(1:7, 1:7), breaks = 0:7 + 0.5, type = "count")
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "histogram[plot.polygon]",
## vp = viewport(layout.pos.row = 9, layout.pos.col = 6))
## ## barchart[plot.polygon]
## pushViewport(viewport(layout.pos.row = 8,
## layout.pos.col = 8,
## yscale = extend.limits(c(0.5,6.5)),
## xscale = c(-1,7)))
## panel.barchart(x = 6:1, y = 1:6)
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "barchart[plot.polygon]",
## vp = viewport(layout.pos.row = 9, layout.pos.col = 8))
## ## superpose.polygon
## superpose.polygon <- trellis.par.get("superpose.polygon")
## len <- max(2, sapply(superpose.polygon, length))
## pushViewport(viewport(layout.pos.row = 11,
## layout.pos.col = 2,
## yscale = extend.limits(c(-.45, .45)),
## xscale = c(-1, len+1)))
## panel.barchart(x = len:1, y = rep(0, len),
## groups = gl(len, 1),
## subscripts = 1:len,
## stack = FALSE)
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "superpose.polygon",
## vp = viewport(layout.pos.row = 12, layout.pos.col = 2))
## ## regions
## regions <- theme$regions
## len <- length(regions$col)
## pushViewport(viewport(layout.pos.row = 11,
## layout.pos.col = 4,
## xscale = c(0,len+1)))
## grid.rect(x = 1:len, width = 1,
## default.units = "native",
## gp =
## gpar(col = "transparent",
## fill = regions$col,
## alpha = regions$alpha))
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "regions",
## vp = viewport(layout.pos.row = 12, layout.pos.col = 4))
## invisible()
## }
## non-graphical options and layout defaults (in terms of grid units)
lattice.getOption <- function(name)
{
get("lattice.options", envir = .LatticeEnv)[[name]]
}
## FIXME: lattice.options(foo == 1) doesn't work?
lattice.options <- function(...)
{
## this would have been really simple if only forms allowed were
## lattice.options("foo", "bar") and
## lattice.options(foo=1, bar=2). But it could also be
## lattice.options(foo=1, "bar"), which makes some juggling necessary
new <- list(...)
if (is.null(names(new)) && length(new) == 1 && is.list(new[[1]])) new <- new[[1]]
old <- .LatticeEnv$lattice.options
## any reason to prefer get("lattice.options", envir = .LatticeEnv)?
## if no args supplied, returns full options list
if (length(new) == 0) return(old)
nm <- names(new)
if (is.null(nm)) return(old[unlist(new)]) ## typically getting options, not setting
isNamed <- nm != "" ## typically all named when setting, but could have mix
if (any(!isNamed)) nm[!isNamed] <- unlist(new[!isNamed])
## so now everything has non-"" names, but only the isNamed ones should be set
## everything should be returned, however
retVal <- old[nm]
names(retVal) <- nm
nm <- nm[isNamed]
## this used to be
## modified <- updateList(retVal[nm], new[nm])
## .LatticeEnv$lattice.options[names(modified)] <- modified
## but then calling lattice.options(foo = NULL) had no effect
## because foo would be missing from modified. So, we now do:
.LatticeEnv$lattice.options <- updateList(old, new[nm])
## return changed entries invisibly
invisible(retVal)
}
.defaultLatticeOptions <- function()
list(save.object = TRUE,
panel.error = "panel.error",
drop.unused.levels = list(cond = TRUE, data = TRUE),
default.theme = getOption("lattice.theme"), ## for back compatibility, usually NULL
legend.bbox = "panel", ## for key$space = "inside"
banking = banking,
histogram.breaks = NULL,
default.args =
list(as.table = FALSE,
aspect = "fill",
auto.key = FALSE,
between = list(x=0, y=0),
grid = FALSE,
##page = NULL,
##main = NULL,
##sub = NULL,
##par.strip.text = NULL,
##layout = NULL,
skip = FALSE,
strip = strip.default,
xscale.components = xscale.components.default,
yscale.components = yscale.components.default,
axis = axis.default),
## extends limits by this amount, to provide padding for
## numeric and factor scales respectively. Note that the
## value for numeric is multiplicative, while factor is
## additive
axis.padding = list(numeric = 0.07, factor = 0.6),
## ticks too close to the limits will not be drawn unless
## explicitly requested. Limits will be contracted by this
## proportion, and anything outside will be skipped.
skip.boundary.labels = 0.02,
## separator for interaction when generating artificial
## factor (see 'allow.multiple' argument in ?xyplot)
interaction.sep = " * ",
## default panel functions
panel.contourplot = "panel.contourplot",
panel.levelplot = "panel.levelplot",
panel.levelplot.raster = "panel.levelplot.raster",
panel.parallel = "panel.parallel",
panel.densityplot = "panel.densityplot",
panel.splom = "panel.splom",
panel.wireframe = "panel.wireframe",
panel.dotplot = "panel.dotplot",
panel.qq = "panel.qq",
panel.stripplot = "panel.stripplot",
panel.xyplot = "panel.xyplot",
panel.qqmath = "panel.qqmath",
panel.barchart = "panel.barchart",
panel.bwplot = "panel.bwplot",
panel.histogram = "panel.histogram",
panel.cloud = "panel.cloud",
panel.pairs = "panel.pairs",
## default prepanel functions
prepanel.default.bwplot = "prepanel.default.bwplot",
prepanel.default.cloud = "prepanel.default.cloud",
prepanel.default.densityplot = "prepanel.default.densityplot",
prepanel.default.histogram = "prepanel.default.histogram",
prepanel.default.levelplot = "prepanel.default.levelplot",
prepanel.default.parallel = "prepanel.default.parallel",
prepanel.default.qq = "prepanel.default.qq",
prepanel.default.qqmath = "prepanel.default.qqmath",
prepanel.default.splom = "prepanel.default.splom",
prepanel.default.xyplot = "prepanel.default.xyplot",
prepanel.default.dotplot = "prepanel.default.bwplot",
prepanel.default.barchart = "prepanel.default.bwplot",
prepanel.default.wireframe = "prepanel.default.cloud",
prepanel.default.contourplot = "prepanel.default.levelplot",
## Complicated grid unit calculations can be slow. Sometimes
## these can be optimized at the cost of potential loss of
## accuracy. This option controls whether such optimization
## should be applied.
## Currently, the only situation where this applies is for
## relation != free (which can be slow for multi-page output
## because the same calculations involving the height of
## multiple strings are repeated). Optimizing converts into
## absolute units, which may give wrong results when the plot
## is replayed on a different device.
optimize.grid = FALSE,
## Axis units. Rather than messing with these, end-users
## should manipulate corresponding settings via
## trellis.par.set()
axis.units =
list(outer =
list(left =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm")),
top =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm")),
right =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm")),
bottom =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm"))),
inner =
list(left =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm")),
top =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm")),
right =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm")),
bottom =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm")))),
## axis.units =
## list(outer =
## list(left =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc")),
## top =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc")),
## right =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc")),
## bottom =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc"))),
## inner =
## list(left =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc")),
## top =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc")),
## right =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc")),
## bottom =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc")))),
layout.heights =
## list(top.padding = list(x = 2, units = "mm", data = NULL),
## main = list(x = 0, units = "grobheight", data = textGrob(label="")),
## main.key.padding = list(x = 2, units = "mm", data = NULL),
## key.top = list(x = 0, units = "grobheight", data = textGrob(label="")),
## key.axis.padding = list(x = 2, units = "mm", data = NULL),
## axis.top = list(x = 0, units = "mm", data = NULL),
## strip = list(x = 1, units = "lines", data = NULL),
## panel = list(x = 1, units = "null", data = NULL),
## axis.panel = list(x = 0, units = "mm", data = NULL),
## between = list(x = 5, units = "mm", data = NULL),
## axis.bottom = list(x = 0, units = "mm", data = NULL),
## axis.xlab.padding = list(x = 2, units = "mm", data = NULL),
## xlab = list(x = 0, units = "grobheight", data = textGrob(label="")),
## xlab.key.padding = list(x = 2, units = "mm", data = NULL),
## key.bottom = list(x = 0, units = "grobheight", data = textGrob(label="")),
## key.sub.padding = list(x = 2, units = "mm", data = NULL),
## sub = list(x = 0, units = "grobheight", data = textGrob(label="")),
## bottom.padding = list(x = 2, units = "mm", data = NULL)),
## layout.widths =
## list(left.padding = list(x = 2, units = "mm", data = NULL),
## key.left = list(x = 0, units = "grobwidth", data = textGrob(label="")),
## key.ylab.padding = list(x = 2, units = "mm", data = NULL),
## ## changed in 2.1.0
## ylab = list(x = 0, units = "grobwidth", data = textGrob(label="")),
## ylab.axis.padding = list(x = 2, units = "mm", data = NULL),
## axis.left = list(x = 0, units = "mm", data = NULL),
## axis.panel = list(x = 0, units = "mm", data = NULL),
## panel = list(x = 1, units = "null", data = NULL),
## between = list(x = 5, units = "mm", data = NULL),
## axis.right = list(x = 0, units = "mm", data = NULL),
## axis.key.padding = list(x = 2, units = "mm", data = NULL),
## key.right = list(x = 0, units = "grobwidth", data = textGrob(label="")),
## right.padding = list(x = 2, units = "mm", data = NULL)),
list(top.padding = list(x = 0.01, units = "snpc", data = NULL),
main = list(x = 0, units = "grobheight", data = textGrob(label="")),
main.key.padding = list(x = 0.01, units = "snpc", data = NULL),
key.top = list(x = 0, units = "grobheight", data = textGrob(label="")),
xlab.top = list(x = 0, units = "grobheight", data = textGrob(label="")),
key.axis.padding = list(x = 0.01, units = "snpc", data = NULL),
axis.top = list(x = 0, units = "mm", data = NULL),
strip = list(x = 1, units = "lines", data = NULL),
panel = list(x = 1, units = "null", data = NULL),
axis.panel = list(x = 0, units = "mm", data = NULL),
between = list(x = 5, units = "mm", data = NULL),
axis.bottom = list(x = 0, units = "mm", data = NULL),
axis.xlab.padding = list(x = 0.01, units = "snpc", data = NULL),
xlab = list(x = 0, units = "grobheight", data = textGrob(label="")),
xlab.key.padding = list(x = 0.01, units = "snpc", data = NULL),
key.bottom = list(x = 0, units = "grobheight", data = textGrob(label="")),
key.sub.padding = list(x = 0.01, units = "snpc", data = NULL),
sub = list(x = 0, units = "grobheight", data = textGrob(label="")),
bottom.padding = list(x = 0.01, units = "snpc", data = NULL)),
layout.widths =
list(left.padding = list(x = 0.01, units = "snpc", data = NULL),
key.left = list(x = 0, units = "grobwidth", data = textGrob(label="")),
key.ylab.padding = list(x = 0.01, units = "snpc", data = NULL),
ylab = list(x = 0, units = "grobwidth", data = textGrob(label="")),
ylab.axis.padding = list(x = 0.01, units = "snpc", data = NULL),
axis.left = list(x = 0, units = "mm", data = NULL),
axis.panel = list(x = 0, units = "mm", data = NULL),
strip.left = list(x = 1, units = "lines", data = NULL),
panel = list(x = 1, units = "null", data = NULL),
between = list(x = 5, units = "mm", data = NULL),
axis.right = list(x = 0, units = "mm", data = NULL),
axis.key.padding = list(x = 0.01, units = "snpc", data = NULL),
ylab.right = list(x = 0, units = "grobwidth", data = textGrob(label="")),
key.right = list(x = 0, units = "grobwidth", data = textGrob(label="")),
right.padding = list(x = 0.01, units = "snpc", data = NULL)),
highlight.gpar = list(col = "red", lwd = 2, fill = "transparent")
)
## Interface to internal storage for use by plot.trellis,
## trellis.focus, etc. The optional argument prefix allows one level
## of nesting for storing plot-specific settings (for example,
## multiple plots in a page, or the panel function of one plot calling
## plot.trellis() again).
lattice.getStatus <- function(name, prefix = NULL)
{
if (is.null(prefix))
get("lattice.status", envir = .LatticeEnv)[[name]]
else
get("lattice.status", envir = .LatticeEnv)[[prefix]][[name]]
}
lattice.setStatus <- function (..., prefix = NULL, clean.first = FALSE)
{
## if clean.first = TRUE, remove previously existing things. This
## is done whenever a new page is started, as otherwise crud from
## previous calls may keep piling up.
dots <- list(...)
if (is.null(names(dots)) && length(dots) == 1 && is.list(dots[[1]]))
dots <- dots[[1]]
if (length(dots) == 0) return()
lattice.status <-
if (clean.first) list()
else get("lattice.status", envir = .LatticeEnv)
if (is.null(prefix))
lattice.status[names(dots)] <- dots
else
lattice.status[[prefix]][names(dots)] <- dots
assign("lattice.status", lattice.status, envir = .LatticeEnv)
invisible()
}
.defaultLatticeStatus <- function()
list(print.more = FALSE,
plot.index = 1) ## keeps track of multiple plots in a page
.defaultLatticePrefixStatus <- function()
list(current.plot.saved = FALSE,
current.plot.multipage = FALSE,
current.focus.row = 0,
current.focus.column = 0,
vp.highlighted = FALSE) ## keeps track of multiple plots in a page
simpleTheme <-
function(col, alpha,
cex, pch, lty, lwd, font, fill, border,
col.points, col.line,
alpha.points, alpha.line)
{
ans <-
list(plot.symbol = list(),
plot.line = list(),
plot.polygon = list(),
superpose.symbol = list(),
superpose.line = list(),
superpose.polygon = list())
setValue <- function(value, name, targets)
{
for (t in targets) ans[[t]][[name]] <<- value
}
if (!missing(col)) setValue(col, "col", 1:6)
if (!missing(alpha)) setValue(alpha, "alpha", 1:6)
if (!missing(cex)) setValue(cex, "cex", c(1, 4))
if (!missing(pch)) setValue(pch, "pch", c(1, 4))
if (!missing(lty)) setValue(lty, "lty", 1:6)
if (!missing(lwd)) setValue(lwd, "lwd", 1:6)
if (!missing(font)) setValue(font, "font", c(1, 4))
if (!missing(fill)) setValue(fill, "fill", c(1, 3, 4, 6))
if (!missing(border)) setValue(border, "border", c(3, 6))
if (!missing(col.points)) setValue(col.points, "col", c(1, 4))
if (!missing(col.line)) setValue(col.line, "col", c(2, 5))
if (!missing(alpha.points)) setValue(alpha.points, "alpha", c(1, 4))
if (!missing(alpha.line)) setValue(alpha.line, "alpha", c(2, 5))
## ensure first three only have scalars
for (nm in c("plot.symbol", "plot.line", "plot.polygon"))
ans[[nm]] <- lapply(ans[[nm]], head, 1)
ans
}
Try the lattice package in your browser
Any scripts or data that you put into this service are public.
lattice documentation built on May 29, 2024, 7:29 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions simpleTheme .defaultLatticePrefixStatus .defaultLatticeStatus lattice.getStatus .defaultLatticeOptions lattice.options lattice.getOption show.settings lset trellis.device trellis.par.set trellis.par.get classic.theme standard.theme canonical.theme custom_theme makeShadePalette lower.saturation col.whitebg
Documented in canonical.theme classic.theme col.whitebg custom_theme lattice.getOption lattice.options lset makeShadePalette show.settings simpleTheme standard.theme trellis.device trellis.par.get trellis.par.set
### Copyright (C) 2001-2006 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
col.whitebg <- function()
list(background = list(col="transparent"),
plot.polygon = list(col="#c8ffc8"),
box.rectangle = list(col="darkgreen"),
box.umbrella = list(col="darkgreen"),
dot.line = list(col="gray90"),
dot.symbol = list(col="darkgreen"),
plot.line = list(col="darkgreen"),
plot.symbol = list(col="darkgreen"),
##regions=list(col=rev(hsv(h=250:349/1000, v=30:129/150,s=.5,
##gamma = .6)))
regions = list(col = heat.colors(100)),
strip.shingle = list(col = c("#ff7f00", "#00ff00", "#00ffff",
"#0080ff", "#ff00ff", "#ff0000", "#ffff00")),
strip.background = list(col = c("#ffe5cc", "#ccffcc", "#ccffff",
"#cce6ff", "#ffccff", "#ffcccc", "#ffffcc")),
reference.line = list(col="gray90"),
superpose.line = list(col = c("darkgreen","red","royalblue",
"brown","orange","turquoise", "orchid"),
lty = 1:7),
superpose.symbol = list(pch = c(1,3,6,0,5,16,17), cex = rep(.7, 7),
col = c("darkgreen","red","royalblue",
"brown","orange","turquoise", "orchid")))
## this function is used to make the superpose.polygon colors less
## saturated versions of the symbol and line colors
lower.saturation <-
function(x, f = 0.2, space = c("RGB", "HCL"))
{
## lower saturation in RGB or HCL space?
space <- match.arg(tolower(space), c("rgb", "hcl"))
## for HCL space ideally colorspace::lighten() should be used
if((space == "hcl") && requireNamespace("colorspace")) {
return(colorspace::lighten(x, amount = 1 - f))
}
## for RGB space the old implementation from lattice is used,
## for HCL space (if colorspace is unavailable) an approximation in LUV is used
RGB <- col2rgb(x)
if(space == "rgb") {
RGB[] <- 255 - RGB
RGB[] <- round(f * RGB)
RGB[] <- 255 - RGB
} else {
## adjust L coordinate of HCL/LUV only, chroma is left as it is
LUV <- convertColor(t(RGB), from = "sRGB", to = "Luv", scale.in = 255)
Lold <- pmin(100, pmax(0, LUV[, "L"]))
LUV[, "L"] <- 100 - (100 - Lold) * f
RGB[] <- t(convertColor(LUV, from = "Luv", to = "sRGB", scale.out = 255))
}
rgb(RGB["red", ],
RGB["green", ],
RGB["blue", ],
maxColorValue = 255)
}
## make a 'shading' function from region colors, for use in
## wireframe(shade = TRUE). 'pref' controls the amount of matte /
## glossy-ness.
makeShadePalette <- function(col.regions, ..., min = 0.05, pref = 0.75)
{
cramp <- colorRamp(col.regions, ...)
function(irr, ref, height)
{
## All arguments will be scalars currently.
## Better alternative: use colorspace::darken()
RGB <- cramp(height)
RGB[] <- (min + (1-min) * irr * ref^pref) * RGB # darken
rgb(RGB[, 1], RGB[, 2], RGB[, 3], maxColorValue = 255)
}
}
## Construct a custom theme based on supplied colors (originally in
## latticeExtra).
custom_theme <-
function(symbol, fill, region,
reference = "gray90", bg = "transparent", fg = "black",
strip.bg = rep("gray95", 7), strip.fg = rep("gray70", 7),
...)
{
theme <-
list(plot.polygon = list(col = fill[1], border = fg[1]),
box.rectangle = list(col= symbol[1]),
box.umbrella = list(col= symbol[1]),
dot.line = list(col = reference),
dot.symbol = list(col = symbol[1]),
plot.line = list(col = symbol[1]),
plot.symbol = list(col= symbol[1]),
reference.line = list(col = reference),
superpose.line = list(col = symbol),
superpose.symbol = list(col = symbol),
superpose.polygon = list(col = fill, border = fg),
regions = list(col = colorRampPalette(region)(100)),
shade.colors = list(palette = makeShadePalette(region)),
strip.background = list(col = strip.bg),
strip.shingle = list(col = strip.fg),
strip.border = list(col = fg),
background = list(col = bg),
add.line = list(col = fg),
add.text = list(col = fg),
box.dot = list(col = fg),
axis.line = list(col = fg),
axis.text = list(col = fg),
strip.border = list(col = fg),
box.3d = list(col = fg),
par.xlab.text = list(col = fg),
par.ylab.text = list(col = fg),
par.zlab.text = list(col = fg),
par.main.text = list(col = fg),
par.sub.text = list(col = fg))
modifyList(modifyList(classic.theme("pdf"), theme),
simpleTheme(...))
}
## (v0.21-7) Extended to make it easy to provide user-supplied colors.
## Default symbol colors are from Okabe-Ito, reordered to match classic theme somewhat better.
## Default fill colors are lightened versions of the symbol colors.
## Default region colors are the sequential HCL palette "YlGnBu" (approximating the one from ColorBrewer).
## Old standard.theme() / canonical.theme() renamed to classic.theme()
canonical.theme <- function(...) standard.theme(...)
standard.theme <- function(name, color = TRUE,
symbol = palette.colors(palette = "Okabe-Ito")[c(6, 2, 4, 7, 3, 5, 8)],
fill = NULL,
region = hcl.colors(14, palette = "YlGnBu", rev = TRUE),
reference = "gray90",
bg = "transparent",
fg = "black",
...)
{
if (is.null(fill))
fill <- if (!missing(symbol)) lower.saturation(symbol, 0.4, space = "HCL")
else c("#94C6FF", "#FFD6AD", "#76E3B8", "#FFBBA9", "#BCE1FF", "#FFF691", "#FFC1E1")
if (!missing(name))
classic.theme(name = name, color = color)
else if (!color)
classic.theme(color = FALSE)
else
custom_theme(symbol = symbol, fill = fill, region = region,
reference = reference, bg = bg, fg = fg, ...)
}
classic.theme <- function(name = .Device, color = name != "postscript")
{
## For the purpose of this function, the only differences in the
## settings/themes arise from the difference in the default
## colors. So, I will first set up the appropriate colors
## according to 'name', and then use those to create the
## theme. The first 16 colors correspond to trellis.settings
## colors, the 17th is the background color.
if (color)
{
## color colors
can.col <-
if (name %in% c("windows", "X11"))
c("#000000", "#00ffff", "#ff00ff", "#00ff00",
"#ff7f00", "#007eff", "#ffff00", "#ff0000",
"#c6ffff", "#ffc3ff", "#c8ffc8", "#ffd18f",
"#a9e2ff", "#ffffc3", "#ff8c8a", "#aaaaaa",
"#909090")
else if (name %in% c("postscript", "pdf", "xfig"))
c("#000000", "#00ffff", "#ff00ff", "#00ff00",
"#ff7f00", "#0080ff", "#ffff00", "#ff0000",
"#ccffff", "#ffccff", "#ccffcc", "#ffe5cc",
"#cce6ff", "#ffffcc", "#ffcccc", "#e6e6e6",
"transparent")
else ## default, same as X11 for now
c("#000000", "#00FFFF", "#FF00FF", "#00FF00",
"#FF7F00", "#007EFF", "#FFFF00", "#FF0000",
"#C6FFFF", "#FFC3FF", "#C8FFC8", "#FFD18F",
"#A9E2FF", "#FFFFC3", "#FF8C8A", "#AAAAAA",
"#909090")
}
else ## b&w colors, same for all devices (8:15 mostly unnecessary)
can.col <-
c("#000000", "#999999", "#4C4C4C", "#E6E6E6", "#F2F2F2",
"#B2B2B2", "#000000", "#030303", "#050505", "#080808",
"#0A0A0A", "#0D0D0D", "#0F0F0F", "#121212", "#151515",
"#AAAAAA", "transparent")
## The following is the canonical definition of what elements are
## valid in any setting. Adding something here should be necessary
## and sufficient.
## Note: For any component with a $font entry, more general
## specifications using $fontfamily and $fontface is also allowed
## (see ?grid::gpar for details). If set, fontsize$text will
## override get.gpar("fontsize") (which in turn usually defaults
## to the device pointsize).
## color settings, modified later if postscript or color = FALSE
ans <-
list(grid.pars = list(), ## set globally at the beginning
fontsize = list(text = 12, points = 8),
background = list(alpha = 1, col = can.col[17]),
panel.background = list(col = "transparent"),
clip = list(panel = "on", strip = "on"),
add.line = list(alpha = 1, col = can.col[1], lty = 1, lwd = 1),
add.text = list(alpha = 1, cex = 1, col = can.col[1], font = 1, lineheight = 1.2),
plot.polygon = list(alpha = 1, col = can.col[2], border = "black", lty = 1, lwd = 1),
box.dot = list(alpha = 1, col = can.col[1], cex = 1, font = 1, pch = 16),
box.rectangle = list(alpha = 1, col = can.col[2], fill = "transparent", lty = 1, lwd = 1),
box.umbrella = list(alpha = 1, col = can.col[2], lty = 2, lwd = 1),
dot.line = list(alpha = 1, col = can.col[16], lty = 1, lwd = 1),
dot.symbol = list(alpha = 1, cex = 0.8, col = can.col[2], font = 1, pch = 16),
plot.line = list(alpha = 1, col = can.col[2], lty = 1, lwd = 1),
plot.symbol = list(alpha = 1, cex = 0.8, col = can.col[2], font = 1, pch = 1, fill = "transparent"),
reference.line = list(alpha = 1, col = can.col[16], lty = 1, lwd = 1),
strip.background = list(alpha = 1, col = can.col[c(12, 11, 9, 13, 10, 15, 14)]),
strip.shingle = list(alpha = 1, col = can.col[c(5, 4, 2, 6, 3, 8, 7)]),
strip.border = list(alpha = 1, col = rep(can.col[1], 7), lty = rep(1, 7), lwd = rep(1, 7)),
superpose.line = list(alpha = 1, col = can.col[2:8], lty = rep(1, 7), lwd = rep(1, 7)),
superpose.symbol = list(alpha = rep(1, 7), cex = rep(0.8, 7), col = can.col[2:8],
fill = lower.saturation(can.col[2:8]),
## WAS: fill = rep("transparent", 7),
font = rep(1, 7), pch = rep(1, 7)),
superpose.polygon= list(alpha = rep(1, 7),
col = lower.saturation(can.col[2:8]), ## WAS can.col[2:8]
border = rep("black", 7), lty = rep(1, 7), lwd = rep(1, 7)),
regions = list(alpha = 1, col = rev(cm.colors(100))),
shade.colors = list(alpha = 1, palette = function(irr, ref, height, saturation = .9) {
hsv(h = height, s = 1 - saturation * (1 - (1-ref)^0.5), v = irr)
}),
axis.line = list(alpha = 1, col = can.col[1], lty = 1, lwd = 1),
axis.text = list(alpha = 1, cex = .8, col = can.col[1], font = 1, lineheight = 1),
## NEW: controls widths of tick marks and padding of labels
axis.components = list(left = list(tck = 1, pad1 = 1, pad2 = 1),
top = list(tck = 1, pad1 = 1, pad2 = 1),
right = list(tck = 1, pad1 = 1, pad2 = 1),
bottom = list(tck = 1, pad1 = 1, pad2 = 1)),
## NEW: controls widths of basic layout's components
layout.heights = list(top.padding = 1,
main = 1,
main.key.padding = 1,
key.top = 1,
xlab.top = 1,
key.axis.padding = 1,
axis.top = 1,
strip = 1,
panel = 1, ## shouldn't be changed
axis.panel = 1, ## can be useful
between = 1,
axis.bottom = 1,
axis.xlab.padding = 1,
xlab = 1,
xlab.key.padding = 1,
key.bottom = 1,
key.sub.padding = 1,
sub = 1,
bottom.padding = 1),
layout.widths = list(left.padding = 1,
key.left = 1,
key.ylab.padding = 1,
ylab = 1,
ylab.axis.padding = 1,
axis.left = 1,
axis.panel = 1, ## can be useful
strip.left = 1,
panel = 1, ## shouldn't be changed
between = 1,
axis.right = 1,
axis.key.padding = 1,
ylab.right = 1,
key.right = 1,
right.padding = 1),
box.3d = list(alpha = 1, col = can.col[1], lty = 1, lwd = 1),
par.title.text = list(alpha = 1, cex = 1.2, col = can.col[1], font = 1, lineheight = 1), # legend title (not used for key yet)
par.xlab.text = list(alpha = 1, cex = 1, col = can.col[1], font = 1, lineheight = 1),
par.ylab.text = list(alpha = 1, cex = 1, col = can.col[1], font = 1, lineheight = 1),
par.zlab.text = list(alpha = 1, cex = 1, col = can.col[1], font = 1, lineheight = 1),
par.main.text = list(alpha = 1, cex = 1.2, col = can.col[1], font = 2, lineheight = 1),
par.sub.text = list(alpha = 1, cex = 1, col = can.col[1], font = 2, lineheight = 1))
if (color)
{
if (name == "postscript" || name == "pdf")
{
ans$plot.symbol$col <- can.col[6]
ans$plot.line$col <- can.col[6]
ans$dot.symbol$col <- can.col[6]
ans$box.rectangle$col <- can.col[6]
ans$box.umbrella$col <- can.col[6]
ans$superpose.symbol$col <- c(can.col[c(6, 3, 4, 8)],
"orange", "darkgreen", "brown")
ans$superpose.symbol$col[c(3, 6)] <- ans$superpose.symbol$col[c(6, 3)]
ans$superpose.line$col <- ans$superpose.symbol$col
}
}
else {
## black and white settings
ans$plot.polygon$col <- can.col[5]
### ans$box.dot$col <- can.col[1]
ans$box.rectangle$col <- can.col[1]
ans$box.umbrella$col <- can.col[1]
### ans$box.umbrella$lty <- 2
ans$dot.line$col <- can.col[4]
ans$dot.symbol$col <- can.col[1]
### ans$dot.symbol$cex <- 0.85
ans$plot.line$col <- can.col[1]
ans$plot.symbol$col <- can.col[1]
## changing this to be like barplot
## ans$regions$col <- gray(29:128/128)
ans$regions$col <- grey(seq(0.3^2.2, 0.9^2.2, length.out = 100)^(1/2.2))
ans$shade.colors$palette <-
function(irr, ref, height, w = .5)
grey(w * irr + (1 - w) * (1 - (1-ref)^.4))
### ans$reference.line$col <- can.col[4]
ans$strip.background$col <- can.col[rep(5, 7)]
ans$strip.shingle$col <- can.col[rep(6, 7)]
ans$superpose.line$col <- can.col[rep(1, 7)]
ans$superpose.line$lty <- 1:7
ans$superpose.symbol$col <- can.col[rep(1, 7)]
ans$superpose.symbol$cex <- rep(0.7, 7)
ans$superpose.symbol$pch <- c(1,3,6,0,5,16,17)
ans$superpose.polygon$col <- grey( (c(6, 12, 7, 11, 8, 10, 9)/15)^.8 )
##ans$superpose.symbol$pch <- c("o","+",">","s","w","#","{")
}
ans
}
## trellis.par.grep <-
## function(pattern,
## theme = trellis.par.get(),
## ...)
## {
## nms <- names(theme)
## id <- grep(pattern, nms)
## ## if match, leave in return value, o.w. apply recursively
## if (length(id)) id <- -id ## id now non-matches
## for (nm in nms[id])
## {
## print(nm)
## theme[[nm]] <-
## if (is.list(theme[[nm]]))
## trellis.par.grep(pattern, theme[[nm]], ...)
## else
## NULL
## }
## if (all(sapply(theme, is.null))) NULL else theme
## }
trellis.par.get <-
function(name = NULL)
{
## the default device is opened if none already open
if (is.null(dev.list())) trellis.device()
lattice.theme <- get("lattice.theme", envir = .LatticeEnv)
## just in case settings for the current device haven't been
## created yet, which may happen if the device is opened by x11(),
## say, (i.e., not by trellis.device()) and no trellis object has
## been printed on this device yet.
if (is.null(lattice.theme[[.Device]])) {
trellis.device(device = .Device, new = FALSE)
lattice.theme <- get("lattice.theme", envir = .LatticeEnv)
}
if (is.null(name))
lattice.theme[[.Device]]
else if (name %in% names(lattice.theme[[.Device]]))
lattice.theme[[.Device]][[name]]
else NULL
}
trellis.par.set <-
function(name, value, ..., theme, warn = TRUE, strict = FALSE)
{
## the default device is opened if none already open
if (is.null(dev.list()))
{
trellis.device()
if (warn)
warning("Note: The default device has been opened to honour attempt to modify trellis settings")
}
## if (name %in% names(lattice.theme[[.Device]])) NEEDED as a safeguard ?
## if (!is.list(value)) stop("value must be a list")
lattice.theme <- get("lattice.theme", envir = .LatticeEnv)
## make sure a list for this device is present
if (is.null(lattice.theme[[.Device]]))
{
trellis.device(device = .Device, new = FALSE)
lattice.theme <- get("lattice.theme", envir = .LatticeEnv)
}
## WAS: lattice.theme[[.Device]][[name]] <- value
if (missing(theme))
{
if (!missing(value))
{
theme <- list(value)
names(theme) <- name
}
else if (!missing(name) && is.list(name))
{
theme <- name
}
else theme <- list(...)
}
else
{
if (is.character(theme)) theme <- get(theme)
if (is.function(theme)) theme <- theme()
if (!is.list(theme))
{
warning("Invalid 'theme' specified")
theme <- NULL
}
}
if (strict)
{
if (strict > 1L) lattice.theme[[.Device]] <- theme
else lattice.theme[[.Device]][names(theme)] <- theme
}
else
lattice.theme[[.Device]] <- updateList(lattice.theme[[.Device]], theme)
assign("lattice.theme", lattice.theme, envir = .LatticeEnv)
invisible()
}
trellis.device <-
function(device = getOption("device"),
color = !(dev.name == "postscript"),
theme = lattice.getOption("default.theme"),
new = TRUE,
retain = FALSE,
...)
{
## Get device function
if (is.character(device))
{
## to make sure this works even if package grDevices is not attached
if (new || is.null(dev.list()))
{
device.call <- try(get(device), silent = TRUE)
if (inherits(device.call, "try-error"))
device.call <-
try(utils::getFromNamespace(device, "grDevices"),
silent = TRUE)
if (inherits(device.call, "try-error"))
stop(gettextf("Could not find device function '%s'", device))
}
dev.name <- device
}
else
{
device.call <- device
dev.name <- deparse(substitute(device))
}
## Start the new device if necessary.
## new = FALSE ignored if no devices open.
## FIXME: remove this warning in some future version
if ("bg" %in% names(list(...)))
warning("'trellis.device' has changed, 'bg' may not be doing what you think it is")
if (new || is.null(dev.list()))
{
device.call(...)
lattice.setStatus(print.more = FALSE)
}
## In the olden days, the defaults were device specific, and given
## by 'canonical.theme(name = .Device, color = color)'. From R
## 2.3.0, this was changed so that all (color) devices now have
## the same defaults, namely 'canonical.theme(name = "pdf", color
## = color)'. The old default can be reinstated by putting
## 'options(lattice.theme = "canonical.theme")' during startup, or
## 'lattice.options(default.theme = "canonical.theme")' after
## loading lattice.
## Update: From lattice 0.21, canonical.theme has been updated to
## use a HCL based color palette by default, and
## 'canonical.theme()' has been renamed to 'classic.theme()'.
## Make sure there's an entry for this device in the theme list
lattice.theme <- get("lattice.theme", envir = .LatticeEnv)
if (!(.Device %in% names(lattice.theme)))
{
lattice.theme[[.Device]] <- standard.theme(color = color)
assign("lattice.theme", lattice.theme, envir = .LatticeEnv)
}
## If retain = FALSE, overwrite with default settings for device
if (!retain) trellis.par.set(standard.theme(color = color))
## get theme as list
if (!is.null(theme) && !is.list(theme))
{
if (is.character(theme)) theme <- get(theme)
if (is.function(theme)) theme <- theme()
if (!is.list(theme))
{
warning("Invalid 'theme' specified")
theme <- NULL
}
}
## apply theme
if (!is.null(theme)) trellis.par.set(theme)
return(invisible())
}
lset <- function(theme = col.whitebg())
{
.Defunct("trellis.par.set")
}
show.settings <- function(x = NULL)
{
old.settings <- trellis.par.get()
on.exit(trellis.par.set(old.settings))
if (!is.null(x)) trellis.par.set(x)
theme <- trellis.par.get()
d <- c("superpose.symbol",
"superpose.line",
"strip.background",
"strip.shingle",
"dot.[symbol, line]",
"box.[dot, rectangle, umbrella]",
"add.[line, text]",
"reference.line",
"plot.[symbol, line]",
"plot.shingle[plot.polygon]",
"histogram[plot.polygon]",
"barchart[plot.polygon]",
"superpose.polygon",
"regions")
d <- factor(d, levels = d)
## We only draw a border box for some panels. To do this, we make
## axis.line globally transparent, and then draw the border on a
## case-by-case basis. But to do that, we need to store the
## original axis.line settings.
par.box <- trellis.par.get("axis.line")
panel.box <- function()
{
panel.fill(col = "transparent",
border = adjustcolor(par.box$col, par.box$alpha),
lty = par.box$lty,
lwd = par.box$lwd)
}
xyplot(d ~ d | d,
prepanel = function(x, y) {
list(ylim = c(0, 1),
xlim = as.character(x),
xat = 1)
},
panel = function(x, y) {
cpl <- current.panel.limits() # ylim = c(0, 1)
rsx <- function(u) # (ReScaleX) map from [0,1]
{
cpl$xlim[1] + u * diff(cpl$xlim)
}
switch(as.character(x),
"superpose.symbol" = {
superpose.symbol <- trellis.par.get("superpose.symbol")
len <- max(2, sapply(superpose.symbol, length))
panel.superpose(x = rep(rsx(ppoints(len)), len),
y = rep(ppoints(len), each = len),
groups = gl(len, len),
subscripts = 1:(len*len))
},
"superpose.line" = {
superpose.line <- trellis.par.get("superpose.line")
len <- max(2, sapply(superpose.line, length))
panel.superpose(x = rep(rsx(c(0,1)), len),
y = rep(ppoints(1:len), each = 2),
groups = gl(len, 2),
subscripts = 1:(2*len),
type = "l")
},
"strip.background" = {
strip.background <- trellis.par.get("strip.background")
strip.border <- trellis.par.get("strip.border")
len <-
max(2, sapply(strip.background, length),
sapply(strip.border, length))
panel.rect(y = ppoints(len), height = 0.5 / len,
xleft = cpl$xlim[1], xright = cpl$xlim[2],
col = adjustcolor(strip.background$col, strip.background$alpha),
border = strip.border$col,
lty = strip.border$lty,
lwd = strip.border$lwd)
},
"strip.shingle" = {
strip.shingle <- trellis.par.get("strip.shingle")
len <- max(2, sapply(strip.shingle, length))
panel.rect(y = ppoints(len), height = 0.5 / len,
xleft = cpl$xlim[1], xright = cpl$xlim[2],
col = adjustcolor(strip.shingle$col, strip.shingle$alpha),
border = "transparent")
},
"dot.[symbol, line]" = {
panel.dotplot(x = rsx(ppoints(5, a = 0)), y = ppoints(5, a = 0))
panel.box()
},
"box.[dot, rectangle, umbrella]" = {
panel.bwplot(x = rsx(ppoints(5)), y = rep(0.5, 5), box.width = 0.15)
panel.box()
},
"add.[line, text]" = {
add.line <- trellis.par.get("add.line")
xx <- seq(0.1, 0.9, length.out = 50)
yy <- 0.5 + .45 * sin(0.1 + 11 * xx)
panel.lines(x = rsx(xx), y = yy,
col = add.line$col, lty = add.line$lty, lwd = add.line$lwd)
panel.text(labels = c("Hello", "World"),
x = rsx(c(.25, .75)), y = c(0.25, 0.75))
panel.box()
},
"reference.line" = {
panel.grid()
panel.box()
},
"plot.[symbol, line]" = {
## plot.symbol <- trellis.par.get("plot.symbol")
## plot.line <- trellis.par.get("plot.line")
## x <- seq(.1, .9, length.out = 20)
## y <- .9 * sin(.1+11*x)
xx <- seq(0.1, 0.9, length.out = 20)
yy <- 0.5 + .4 * sin(0.1 + 11 * xx)
panel.xyplot(x = rsx(xx + 0.05), y = yy + 0.01, type = "l")
panel.xyplot(x = rsx(xx - 0.05), y = yy - 0.01)
panel.box()
},
"plot.shingle[plot.polygon]" = {
xx <- seq(0.1, 0.4, length.out = 5)
yy <- ppoints(5)
panel.barchart(x = rsx(xx + 0.5), y = yy, origin = rsx(xx),
reference = FALSE, horizontal = TRUE,
box.width = 1/10)
panel.box()
},
"histogram[plot.polygon]" = {
xx <- ppoints(7, 0)
panel.barchart(x = rsx(xx), y = (2:8)/9, horizontal = FALSE,
origin = 1/18, box.width = diff(rsx(xx))[1],
reference = FALSE)
panel.box()
},
"barchart[plot.polygon]" = {
xx <- ppoints(6)
panel.barchart(x = rev(rsx(xx)), y = xx,
origin = cpl$xlim[1], box.width = 1/12)
panel.box()
},
"superpose.polygon" = {
superpose.polygon <- trellis.par.get("superpose.polygon")
len <- max(2, sapply(superpose.polygon, length))
xx <- ppoints(len)
panel.barchart(x = rsx(rev(xx)), y = rep(0.5, len),
groups = gl(len, 1),
subscripts = seq_len(len),
stack = FALSE,
box.width = 0.9)
panel.box()
},
"regions" = {
panel.levelplot(x = do.breaks(cpl$xlim, 98),
y = rep(0.5, 99),
z = 1:99 + 0.5,
at = 1:100,
region = TRUE,
subscripts = 1:99)
panel.box()
})
},
## layout = c(4, 4),
par.settings = modifyList(theme,
list(axis.line = list(col = "transparent"),
clip = list(panel = "off"))),
as.table = TRUE, strip = FALSE, xlab = "", ylab = "",
between = list(x = 1, y = 0.5),
scales = list(relation = "free",
y = list(draw = FALSE, axs = "i"),
x = list(tck = 0, axs = "r")))
}
## show.settings.old <- function(x = NULL)
## {
## old.settings <- trellis.par.get()
## on.exit(trellis.par.set(old.settings))
## if (!is.null(x)) trellis.par.set(x)
## theme <- trellis.par.get()
## n.row <- 13
## n.col <- 9
## heights.x <- rep(1, n.row)
## heights.units <- rep("lines", n.row)
## heights.units[c(2, 5, 8, 11)] <- "null"
## widths.x <- rep(1, n.row)
## widths.units <- rep("lines", n.row)
## widths.units[c(2, 4, 6, 8)] <- "null"
## page.layout <-
## grid.layout(nrow = n.row, ncol = n.col,
## widths = unit(widths.x, widths.units),
## heights = unit(heights.x, heights.units))
## if (!lattice.getStatus("print.more")) grid.newpage()
## lattice.setStatus(print.more = FALSE)
## grid.rect(gp = gpar(fill = theme$background$col,
## col = "transparent"))
## pushViewport(viewport(layout = page.layout,
## gp = gpar(fontsize = theme$fontsize$text)))
## gp.box <-
## gpar(col = theme$axis.line$col,
## lty = theme$axis.line$lty,
## lwd = theme$axis.line$lwd,
## alpha = theme$axis.line$alpha,
## fill = "transparent")
## ## superpose.symbol
## superpose.symbol <- theme$superpose.symbol
## len <- max(2, sapply(superpose.symbol, length))
## pushViewport(viewport(layout.pos.row = 2,
## layout.pos.col = 2,
## yscale = c(0,len+1),
## xscale = c(0,len+1)))
## panel.superpose(x = rep(1:len, len),
## y = rep(1:len, each = len),
## groups = gl(len, len),
## subscripts = 1:(len*len))
## popViewport()
## grid.text(label = "superpose.symbol",
## vp = viewport(layout.pos.row = 3, layout.pos.col = 2))
## ## superpose.line
## superpose.line <- theme$superpose.line
## len <- max(2, sapply(superpose.line, length))
## pushViewport(viewport(layout.pos.row = 2,
## layout.pos.col = 4,
## yscale = c(0,len+1),
## xscale = c(0, 1)))
## panel.superpose(x = rep(c(0,1), len),
## y = rep(1:len, each = 2),
## groups = gl(len, 2),
## subscripts = 1:(2*len),
## type = "l")
## popViewport()
## grid.text(label = "superpose.line",
## vp = viewport(layout.pos.row = 3, layout.pos.col = 4))
## ## strip.background
## strip.background <- theme$strip.background
## strip.border <- theme$strip.border
## len <-
## max(sapply(strip.background, length),
## sapply(strip.border, length))
## pushViewport(viewport(layout.pos.row = 2,
## layout.pos.col = 6,
## yscale = c(0, len+1),
## xscale = c(0, 1)))
## grid.rect(y = unit(1:len, "native"),
## height = unit(0.5, "native"),
## gp =
## gpar(fill = strip.background$col,
## alpha = strip.background$alpha,
## col = strip.border$col,
## lty = strip.border$lty,
## lwd = strip.border$lwd))
## popViewport()
## grid.text(label = "strip.background",
## vp = viewport(layout.pos.row = 3, layout.pos.col = 6))
## ## strip.shingle
## strip.shingle <- theme$strip.shingle
## len <- max(sapply(strip.shingle, length))
## pushViewport(viewport(layout.pos.row = 2,
## layout.pos.col = 8,
## yscale = c(0,len+1),
## xscale = c(0,1)))
## grid.rect(y = unit(1:len, "native"),
## height = unit(0.5, "native"),
## gp =
## gpar(fill = strip.shingle$col,
## alpha = strip.shingle$alpha,
## col = "transparent", lwd = 0.0001))
## popViewport()
## grid.text(label = "strip.shingle",
## vp = viewport(layout.pos.row = 3, layout.pos.col = 8))
## ## dot.[symbol, line]
## pushViewport(viewport(layout.pos.row = 5,
## layout.pos.col = 2,
## yscale = extend.limits(c(0,6)),
## xscale = c(0,6)))
## panel.dotplot(x = 1:5, y = 1:5)
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "dot.[symbol, line]",
## vp = viewport(layout.pos.row = 6, layout.pos.col = 2))
## ## box.[dot, rectangle, umbrella]
## pushViewport(viewport(layout.pos.row = 5,
## layout.pos.col = 4,
## yscale = c(-2, 2),
## xscale = c(0,6)))
## panel.bwplot(x = 1:5, y = rep(0, 5))
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "box.[dot, rectangle, umbrella]",
## vp = viewport(layout.pos.row = 6, layout.pos.col = 4))
## ## add.[line, text]
## add.text <- theme$add.text
## add.line <- theme$add.line
## pushViewport(viewport(layout.pos.row = 5,
## layout.pos.col = 6,
## yscale = c(-1,1),
## xscale = c(0,1)))
## x <- seq(.1, .9, length.out = 50)
## y <- .9 * sin(.1+11*x)
## llines(x = x, y = y, type = "l", col = add.line$col,
## lty = add.line$lty, lwd = add.line$lwd)
## ltext(labels = c("Hello", "World"),
## x = c(.25, .75), y = c(-.5, .5))
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "add.[line, text]",
## vp = viewport(layout.pos.row = 6, layout.pos.col = 6))
## ## reference.line
## pushViewport(viewport(layout.pos.row = 5,
## layout.pos.col = 8,
## yscale = c(0,4),
## xscale = c(0,4)))
## panel.grid()
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "reference.line",
## vp = viewport(layout.pos.row = 6, layout.pos.col = 8))
## ## plot.[symbol, line]
## plot.symbol <- theme$plot.symbol
## plot.line <- theme$plot.line
## pushViewport(viewport(layout.pos.row = 8,
## layout.pos.col = 2,
## yscale = c(-1.1,1.1),
## xscale = c(-.1,1.1)))
## x <- seq(.1, .9, length.out = 20)
## y <- .9 * sin(.1+11*x)
## panel.xyplot(x = x+.05, y = y+.1, type = "l")
## panel.xyplot(x = x-.05, y = y-.1)
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "plot.[symbol, line]",
## vp = viewport(layout.pos.row = 9, layout.pos.col = 2))
## ## plot.shingle[plot.polygon]
## plot.polygon <- theme$plot.polygon
## pushViewport(viewport(layout.pos.row = 8,
## layout.pos.col = 4,
## yscale = extend.limits(c(0,6)),
## xscale = extend.limits(c(1,10))))
## grid.rect(x = c(3.5, 4.5, 5.5, 6.5, 7.5), width = rep(5,5),
## y = c(1,2,3,4,5), height = rep(.5, ,5),
## default.units = "native",
## gp =
## gpar(fill = plot.polygon$col,
## col = plot.polygon$border,
## alpha = plot.polygon$alpha,
## lty = plot.polygon$lty,
## lwd = plot.polygon$lwd))
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "plot.shingle[plot.polygon]",
## vp = viewport(layout.pos.row = 9, layout.pos.col = 4))
## ## histogram[plot.polygon]
## pushViewport(viewport(layout.pos.row = 8,
## layout.pos.col = 6,
## yscale = extend.limits(c(0,7)),
## xscale = extend.limits(c(0.5,7.5))))
## panel.histogram(x = rep(1:7, 1:7), breaks = 0:7 + 0.5, type = "count")
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "histogram[plot.polygon]",
## vp = viewport(layout.pos.row = 9, layout.pos.col = 6))
## ## barchart[plot.polygon]
## pushViewport(viewport(layout.pos.row = 8,
## layout.pos.col = 8,
## yscale = extend.limits(c(0.5,6.5)),
## xscale = c(-1,7)))
## panel.barchart(x = 6:1, y = 1:6)
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "barchart[plot.polygon]",
## vp = viewport(layout.pos.row = 9, layout.pos.col = 8))
## ## superpose.polygon
## superpose.polygon <- trellis.par.get("superpose.polygon")
## len <- max(2, sapply(superpose.polygon, length))
## pushViewport(viewport(layout.pos.row = 11,
## layout.pos.col = 2,
## yscale = extend.limits(c(-.45, .45)),
## xscale = c(-1, len+1)))
## panel.barchart(x = len:1, y = rep(0, len),
## groups = gl(len, 1),
## subscripts = 1:len,
## stack = FALSE)
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "superpose.polygon",
## vp = viewport(layout.pos.row = 12, layout.pos.col = 2))
## ## regions
## regions <- theme$regions
## len <- length(regions$col)
## pushViewport(viewport(layout.pos.row = 11,
## layout.pos.col = 4,
## xscale = c(0,len+1)))
## grid.rect(x = 1:len, width = 1,
## default.units = "native",
## gp =
## gpar(col = "transparent",
## fill = regions$col,
## alpha = regions$alpha))
## grid.rect(gp = gp.box)
## popViewport()
## grid.text(label = "regions",
## vp = viewport(layout.pos.row = 12, layout.pos.col = 4))
## invisible()
## }
## non-graphical options and layout defaults (in terms of grid units)
lattice.getOption <- function(name)
{
get("lattice.options", envir = .LatticeEnv)[[name]]
}
## FIXME: lattice.options(foo == 1) doesn't work?
lattice.options <- function(...)
{
## this would have been really simple if only forms allowed were
## lattice.options("foo", "bar") and
## lattice.options(foo=1, bar=2). But it could also be
## lattice.options(foo=1, "bar"), which makes some juggling necessary
new <- list(...)
if (is.null(names(new)) && length(new) == 1 && is.list(new[[1]])) new <- new[[1]]
old <- .LatticeEnv$lattice.options
## any reason to prefer get("lattice.options", envir = .LatticeEnv)?
## if no args supplied, returns full options list
if (length(new) == 0) return(old)
nm <- names(new)
if (is.null(nm)) return(old[unlist(new)]) ## typically getting options, not setting
isNamed <- nm != "" ## typically all named when setting, but could have mix
if (any(!isNamed)) nm[!isNamed] <- unlist(new[!isNamed])
## so now everything has non-"" names, but only the isNamed ones should be set
## everything should be returned, however
retVal <- old[nm]
names(retVal) <- nm
nm <- nm[isNamed]
## this used to be
## modified <- updateList(retVal[nm], new[nm])
## .LatticeEnv$lattice.options[names(modified)] <- modified
## but then calling lattice.options(foo = NULL) had no effect
## because foo would be missing from modified. So, we now do:
.LatticeEnv$lattice.options <- updateList(old, new[nm])
## return changed entries invisibly
invisible(retVal)
}
.defaultLatticeOptions <- function()
list(save.object = TRUE,
panel.error = "panel.error",
drop.unused.levels = list(cond = TRUE, data = TRUE),
default.theme = getOption("lattice.theme"), ## for back compatibility, usually NULL
legend.bbox = "panel", ## for key$space = "inside"
banking = banking,
histogram.breaks = NULL,
default.args =
list(as.table = FALSE,
aspect = "fill",
auto.key = FALSE,
between = list(x=0, y=0),
grid = FALSE,
##page = NULL,
##main = NULL,
##sub = NULL,
##par.strip.text = NULL,
##layout = NULL,
skip = FALSE,
strip = strip.default,
xscale.components = xscale.components.default,
yscale.components = yscale.components.default,
axis = axis.default),
## extends limits by this amount, to provide padding for
## numeric and factor scales respectively. Note that the
## value for numeric is multiplicative, while factor is
## additive
axis.padding = list(numeric = 0.07, factor = 0.6),
## ticks too close to the limits will not be drawn unless
## explicitly requested. Limits will be contracted by this
## proportion, and anything outside will be skipped.
skip.boundary.labels = 0.02,
## separator for interaction when generating artificial
## factor (see 'allow.multiple' argument in ?xyplot)
interaction.sep = " * ",
## default panel functions
panel.contourplot = "panel.contourplot",
panel.levelplot = "panel.levelplot",
panel.levelplot.raster = "panel.levelplot.raster",
panel.parallel = "panel.parallel",
panel.densityplot = "panel.densityplot",
panel.splom = "panel.splom",
panel.wireframe = "panel.wireframe",
panel.dotplot = "panel.dotplot",
panel.qq = "panel.qq",
panel.stripplot = "panel.stripplot",
panel.xyplot = "panel.xyplot",
panel.qqmath = "panel.qqmath",
panel.barchart = "panel.barchart",
panel.bwplot = "panel.bwplot",
panel.histogram = "panel.histogram",
panel.cloud = "panel.cloud",
panel.pairs = "panel.pairs",
## default prepanel functions
prepanel.default.bwplot = "prepanel.default.bwplot",
prepanel.default.cloud = "prepanel.default.cloud",
prepanel.default.densityplot = "prepanel.default.densityplot",
prepanel.default.histogram = "prepanel.default.histogram",
prepanel.default.levelplot = "prepanel.default.levelplot",
prepanel.default.parallel = "prepanel.default.parallel",
prepanel.default.qq = "prepanel.default.qq",
prepanel.default.qqmath = "prepanel.default.qqmath",
prepanel.default.splom = "prepanel.default.splom",
prepanel.default.xyplot = "prepanel.default.xyplot",
prepanel.default.dotplot = "prepanel.default.bwplot",
prepanel.default.barchart = "prepanel.default.bwplot",
prepanel.default.wireframe = "prepanel.default.cloud",
prepanel.default.contourplot = "prepanel.default.levelplot",
## Complicated grid unit calculations can be slow. Sometimes
## these can be optimized at the cost of potential loss of
## accuracy. This option controls whether such optimization
## should be applied.
## Currently, the only situation where this applies is for
## relation != free (which can be slow for multi-page output
## because the same calculations involving the height of
## multiple strings are repeated). Optimizing converts into
## absolute units, which may give wrong results when the plot
## is replayed on a different device.
optimize.grid = FALSE,
## Axis units. Rather than messing with these, end-users
## should manipulate corresponding settings via
## trellis.par.set()
axis.units =
list(outer =
list(left =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm")),
top =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm")),
right =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm")),
bottom =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm"))),
inner =
list(left =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm")),
top =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm")),
right =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm")),
bottom =
list(tick = list(x = 2, units = "mm"),
pad1 = list(x = 2, units = "mm"),
pad2 = list(x = 2, units = "mm")))),
## axis.units =
## list(outer =
## list(left =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc")),
## top =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc")),
## right =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc")),
## bottom =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc"))),
## inner =
## list(left =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc")),
## top =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc")),
## right =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc")),
## bottom =
## list(tick = list(x = 0.01, units = "snpc"),
## pad1 = list(x = 0.01, units = "snpc"),
## pad2 = list(x = 0.01, units = "snpc")))),
layout.heights =
## list(top.padding = list(x = 2, units = "mm", data = NULL),
## main = list(x = 0, units = "grobheight", data = textGrob(label="")),
## main.key.padding = list(x = 2, units = "mm", data = NULL),
## key.top = list(x = 0, units = "grobheight", data = textGrob(label="")),
## key.axis.padding = list(x = 2, units = "mm", data = NULL),
## axis.top = list(x = 0, units = "mm", data = NULL),
## strip = list(x = 1, units = "lines", data = NULL),
## panel = list(x = 1, units = "null", data = NULL),
## axis.panel = list(x = 0, units = "mm", data = NULL),
## between = list(x = 5, units = "mm", data = NULL),
## axis.bottom = list(x = 0, units = "mm", data = NULL),
## axis.xlab.padding = list(x = 2, units = "mm", data = NULL),
## xlab = list(x = 0, units = "grobheight", data = textGrob(label="")),
## xlab.key.padding = list(x = 2, units = "mm", data = NULL),
## key.bottom = list(x = 0, units = "grobheight", data = textGrob(label="")),
## key.sub.padding = list(x = 2, units = "mm", data = NULL),
## sub = list(x = 0, units = "grobheight", data = textGrob(label="")),
## bottom.padding = list(x = 2, units = "mm", data = NULL)),
## layout.widths =
## list(left.padding = list(x = 2, units = "mm", data = NULL),
## key.left = list(x = 0, units = "grobwidth", data = textGrob(label="")),
## key.ylab.padding = list(x = 2, units = "mm", data = NULL),
## ## changed in 2.1.0
## ylab = list(x = 0, units = "grobwidth", data = textGrob(label="")),
## ylab.axis.padding = list(x = 2, units = "mm", data = NULL),
## axis.left = list(x = 0, units = "mm", data = NULL),
## axis.panel = list(x = 0, units = "mm", data = NULL),
## panel = list(x = 1, units = "null", data = NULL),
## between = list(x = 5, units = "mm", data = NULL),
## axis.right = list(x = 0, units = "mm", data = NULL),
## axis.key.padding = list(x = 2, units = "mm", data = NULL),
## key.right = list(x = 0, units = "grobwidth", data = textGrob(label="")),
## right.padding = list(x = 2, units = "mm", data = NULL)),
list(top.padding = list(x = 0.01, units = "snpc", data = NULL),
main = list(x = 0, units = "grobheight", data = textGrob(label="")),
main.key.padding = list(x = 0.01, units = "snpc", data = NULL),
key.top = list(x = 0, units = "grobheight", data = textGrob(label="")),
xlab.top = list(x = 0, units = "grobheight", data = textGrob(label="")),
key.axis.padding = list(x = 0.01, units = "snpc", data = NULL),
axis.top = list(x = 0, units = "mm", data = NULL),
strip = list(x = 1, units = "lines", data = NULL),
panel = list(x = 1, units = "null", data = NULL),
axis.panel = list(x = 0, units = "mm", data = NULL),
between = list(x = 5, units = "mm", data = NULL),
axis.bottom = list(x = 0, units = "mm", data = NULL),
axis.xlab.padding = list(x = 0.01, units = "snpc", data = NULL),
xlab = list(x = 0, units = "grobheight", data = textGrob(label="")),
xlab.key.padding = list(x = 0.01, units = "snpc", data = NULL),
key.bottom = list(x = 0, units = "grobheight", data = textGrob(label="")),
key.sub.padding = list(x = 0.01, units = "snpc", data = NULL),
sub = list(x = 0, units = "grobheight", data = textGrob(label="")),
bottom.padding = list(x = 0.01, units = "snpc", data = NULL)),
layout.widths =
list(left.padding = list(x = 0.01, units = "snpc", data = NULL),
key.left = list(x = 0, units = "grobwidth", data = textGrob(label="")),
key.ylab.padding = list(x = 0.01, units = "snpc", data = NULL),
ylab = list(x = 0, units = "grobwidth", data = textGrob(label="")),
ylab.axis.padding = list(x = 0.01, units = "snpc", data = NULL),
axis.left = list(x = 0, units = "mm", data = NULL),
axis.panel = list(x = 0, units = "mm", data = NULL),
strip.left = list(x = 1, units = "lines", data = NULL),
panel = list(x = 1, units = "null", data = NULL),
between = list(x = 5, units = "mm", data = NULL),
axis.right = list(x = 0, units = "mm", data = NULL),
axis.key.padding = list(x = 0.01, units = "snpc", data = NULL),
ylab.right = list(x = 0, units = "grobwidth", data = textGrob(label="")),
key.right = list(x = 0, units = "grobwidth", data = textGrob(label="")),
right.padding = list(x = 0.01, units = "snpc", data = NULL)),
highlight.gpar = list(col = "red", lwd = 2, fill = "transparent")
)
## Interface to internal storage for use by plot.trellis,
## trellis.focus, etc. The optional argument prefix allows one level
## of nesting for storing plot-specific settings (for example,
## multiple plots in a page, or the panel function of one plot calling
## plot.trellis() again).
lattice.getStatus <- function(name, prefix = NULL)
{
if (is.null(prefix))
get("lattice.status", envir = .LatticeEnv)[[name]]
else
get("lattice.status", envir = .LatticeEnv)[[prefix]][[name]]
}
lattice.setStatus <- function (..., prefix = NULL, clean.first = FALSE)
{
## if clean.first = TRUE, remove previously existing things. This
## is done whenever a new page is started, as otherwise crud from
## previous calls may keep piling up.
dots <- list(...)
if (is.null(names(dots)) && length(dots) == 1 && is.list(dots[[1]]))
dots <- dots[[1]]
if (length(dots) == 0) return()
lattice.status <-
if (clean.first) list()
else get("lattice.status", envir = .LatticeEnv)
if (is.null(prefix))
lattice.status[names(dots)] <- dots
else
lattice.status[[prefix]][names(dots)] <- dots
assign("lattice.status", lattice.status, envir = .LatticeEnv)
invisible()
}
.defaultLatticeStatus <- function()
list(print.more = FALSE,
plot.index = 1) ## keeps track of multiple plots in a page
.defaultLatticePrefixStatus <- function()
list(current.plot.saved = FALSE,
current.plot.multipage = FALSE,
current.focus.row = 0,
current.focus.column = 0,
vp.highlighted = FALSE) ## keeps track of multiple plots in a page
simpleTheme <-
function(col, alpha,
cex, pch, lty, lwd, font, fill, border,
col.points, col.line,
alpha.points, alpha.line)
{
ans <-
list(plot.symbol = list(),
plot.line = list(),
plot.polygon = list(),
superpose.symbol = list(),
superpose.line = list(),
superpose.polygon = list())
setValue <- function(value, name, targets)
{
for (t in targets) ans[[t]][[name]] <<- value
}
if (!missing(col)) setValue(col, "col", 1:6)
if (!missing(alpha)) setValue(alpha, "alpha", 1:6)
if (!missing(cex)) setValue(cex, "cex", c(1, 4))
if (!missing(pch)) setValue(pch, "pch", c(1, 4))
if (!missing(lty)) setValue(lty, "lty", 1:6)
if (!missing(lwd)) setValue(lwd, "lwd", 1:6)
if (!missing(font)) setValue(font, "font", c(1, 4))
if (!missing(fill)) setValue(fill, "fill", c(1, 3, 4, 6))
if (!missing(border)) setValue(border, "border", c(3, 6))
if (!missing(col.points)) setValue(col.points, "col", c(1, 4))
if (!missing(col.line)) setValue(col.line, "col", c(2, 5))
if (!missing(alpha.points)) setValue(alpha.points, "alpha", c(1, 4))
if (!missing(alpha.line)) setValue(alpha.line, "alpha", c(2, 5))
## ensure first three only have scalars
for (nm in c("plot.symbol", "plot.line", "plot.polygon"))
ans[[nm]] <- lapply(ans[[nm]], head, 1)
ans
}
Try the lattice package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.