Nothing
R/legend.R
In lattice: Trellis Graphics for R
Defines functions
draw.colorkey
widthDetails.latticeKey
draw.key
componentName
simpleKey
drawSimpleKey
autoKeyLegend
defaultLegendPosition
needAutoKey
construct.legend
Documented in
draw.colorkey
draw.key
simpleKey
### 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
construct.legend <-
function(legend = NULL, key = NULL, fun = "draw.key")
{
if (is.null(legend) && is.null(key)) return(NULL)
if (is.null(legend)) legend <- list()
if (!is.null(key))
{
space <- key$space
x <- y <- corner <- NULL
if (is.null(space))
{
if (any(c("x", "y", "corner") %in% names(key)))
{
stopifnot(is.null(x) || (length(x) == 1 && x >= 0 && x <= 1))
stopifnot(is.null(y) || (length(y) == 1 && y >= 0 && y <= 1))
stopifnot(is.null(corner) ||
(length(corner) == 2 &&
all(corner %in% c(0, 1))))
space <- "inside"
x <- key$x
y <- key$y
corner <- key$corner
## check for valid values
}
else
space <- "top"
}
if (space != "inside" && space %in% names(legend))
stop(gettextf("component '%s' duplicated in key and legend", space))
key.legend <- list(fun = fun, args = list(key = key, draw = FALSE))
key.legend$x <- x
key.legend$y <- y
key.legend$corner <- corner
legend <- c(list(key.legend), legend)
names(legend)[1] <- space
}
legend
}
## A convenience function for deciding whether an ``automatic'' legend
## should be drawn following instructions contained in the 'auto.key'
## argument.
needAutoKey <- function(auto.key, groups = NULL)
{
((!is.null(groups) && (isTRUE(auto.key) || is.list(auto.key))) ||
(is.list(auto.key) && !is.null(auto.key$text)))
## old behaviour was:
## !is.null(groups) && (is.list(auto.key) || isTRUE(auto.key))
}
## Pick a position for the legend based on its contents. Mainly used
## for 'auto.key' via 'drawSimpleKey()'. Explicit 'space' is honored
## in preference to anything else, otherwise 'right', unless 'columns
## > 1'.
defaultLegendPosition <- function(x)
{
if (!is.null(x$space)) return(x$space)
if (any(c("x", "y", "corner") %in% names(x))) "inside"
else if (!is.null(x$columns) && any(x$columns > 1)) "top"
else "right"
}
autoKeyLegend <- function(args, more)
{
if (is.list(more)) args <- updateList(args, more)
legend <- list(list(fun = "drawSimpleKey", args = args))
## These should be missing rather than NULL, so assigned separately
legend[[1]]$x <- legend[[1]]$args$x
legend[[1]]$y <- legend[[1]]$args$y
legend[[1]]$corner <- legend[[1]]$args$corner
names(legend) <- defaultLegendPosition(legend[[1]]$args)
legend
}
## convenience function for auto.key
drawSimpleKey <- function(...)
draw.key(simpleKey(...), draw = FALSE)
## convenience function for the most common type of key
simpleKey <-
function(text, points = TRUE,
rectangles = FALSE,
lines = FALSE,
col = add.text$col,
cex = add.text$cex,
alpha = add.text$alpha,
font = add.text$font,
fontface = add.text$fontface,
fontfamily = add.text$fontfamily,
lineheight = add.text$lineheight,
...)
{
add.text <- trellis.par.get("add.text")
foo <- seq_along(text)
ans <-
list(text = list(lab = text),
col = col, cex = cex, alpha = alpha,
font = font,
fontface = fontface,
fontfamily = fontfamily,
...)
if (points) ans$points <-
Rows(trellis.par.get("superpose.symbol"), foo)
if (rectangles) ans$rectangles <-
Rows(trellis.par.get("superpose.polygon"), foo)
if (lines) ans$lines <-
updateList(Rows(trellis.par.get("superpose.symbol"), foo), ## for pch
Rows(trellis.par.get("superpose.line"), foo))
ans
}
componentName <- function(name, x, y) {
trellis.grobname(paste(name, x, y, sep="."), type="key")
}
draw.key <- function(key, draw = FALSE, vp = NULL, ...)
{
if (!is.list(key)) stop("key must be a list")
max.length <- 0
## maximum of the `row-lengths' of the above
## components. There is some scope for confusion
## here, e.g., if col is specified in key as a
## length 6 vector, and then lines=list(lty=1:3),
## what should be the length of that lines column ?
## If 3, what happens if lines=list() ?
## (Strangely enough, S+ accepts lines=list()
## if col (etc) is NOT specified outside, but not
## if it is)
process.key <-
function(reverse.rows = FALSE, ## invert rows (e.g. for barchart, stack = FALSE)
between = 2,
align = TRUE,
title = NULL,
rep = TRUE,
background = trellis.par.get("background")$col,
alpha.background = 1,
border = FALSE,
transparent = FALSE,
col = "black",
alpha = 1,
lty = 1,
lwd = 1,
font = 1,
fontface = NULL,
fontfamily = NULL,
pch = 8,
cex = 1,
fill = "transparent",
adj = 0,
type = "l",
size = 5,
height = 1,
angle = 0,
density = -1,
cex.title = 1.5 * max(cex),
padding.text = 1,
lineheight = 1,
columns = 1,
divide = 3,
between.columns = 3,
## to avoid partial matching, anything starting with
## lines, points, rect, text must come after ...
...,
lines.title = 2)
{
list(reverse.rows = reverse.rows,
between = between,
align = align,
title = title,
rep = rep,
background = background,
alpha.background = alpha.background,
border = border,
transparent = transparent,
col = col,
alpha = alpha,
lty = lty,
lwd = lwd,
font = font,
fontface = fontface,
fontfamily = fontfamily,
pch = pch,
cex = cex,
fill = fill,
adj = adj,
type = type,
size = size,
height = height,
angle = angle,
density = density,
cex.title = cex.title,
padding.text = padding.text,
lineheight = lineheight,
columns = columns,
divide = divide,
between.columns = between.columns,
lines.title = lines.title,
...)
}
fontsize.points <- trellis.par.get("fontsize")$points
key <- do.call(process.key, key, quote = TRUE)
key.length <- length(key)
key.names <- names(key) # Need to update
if (is.logical(key$border))
key$border <-
if (key$border) "black"
else "transparent"
components <- list()
for(i in 1:key.length)
{
curname <- pmatch(key.names[i], c("text", "rectangles", "lines", "points"))
if (is.na(curname))
{
;## do nothing
}
else if (curname == 1) # "text"
{
if (!(is.characterOrExpression(key[[i]][[1]])))
stop("first component of text must be vector of labels")
pars <-
list(labels = key[[i]][[1]],
col = key$col,
alpha = key$alpha,
adj = key$adj,
cex = key$cex,
lineheight = key$lineheight,
font = key$font,
fontface = key$fontface,
fontfamily = key$fontfamily)
pars <- pars[!sapply(pars, is.null)] # remove NULL components
key[[i]][[1]] <- NULL
key[[i]] <- complete_names(key[[i]], pars, allow.invalid = TRUE)
pars[names(key[[i]])] <- key[[i]]
tmplen <- length(pars$labels)
for (j in 1:length(pars))
if (is.character(pars))
pars[[j]] <- rep(pars[[j]], length.out = tmplen)
max.length <- max(max.length, tmplen)
components[[length(components)+1]] <-
list(type = "text", pars = pars, length = tmplen)
}
else if (curname == 2) # "rectangles"
{
pars <-
list(col = key$col,
border = "black",
alpha = key$alpha,
size = key$size,
height = key$height,
angle = key$angle,
density = key$density)
pars <- pars[!sapply(pars, is.null)] # remove NULL components
key[[i]] <- complete_names(key[[i]], pars, allow.invalid = TRUE)
pars[names(key[[i]])] <- key[[i]]
tmplen <- max(unlist(lapply(pars,length)))
max.length <- max(max.length, tmplen)
components[[length(components)+1]] <-
list(type = "rectangles", pars = pars, length = tmplen)
}
else if (curname == 3) # "lines"
{
pars <-
list(col = key$col,
alpha = key$alpha,
size = key$size,
lty = key$lty,
cex = key$cex,
pch = key$pch,
fill = key$fill,
lwd = key$lwd,
type = key$type)
pars <- pars[!sapply(pars, is.null)] # remove NULL components
key[[i]] <- complete_names(key[[i]], pars, allow.invalid = TRUE)
pars[names(key[[i]])] <- key[[i]]
tmplen <- max(unlist(lapply(pars,length)))
max.length <- max(max.length, tmplen)
components[[length(components)+1]] <-
list(type = "lines", pars = pars, length = tmplen)
}
else if (curname == 4) # "points"
{
pars <-
list(col = key$col,
alpha = key$alpha,
cex = key$cex,
pch = key$pch,
lwd = key$lwd,
fill = key$fill,
font = key$font,
fontface = key$fontface,
fontfamily = key$fontfamily)
pars <- pars[!sapply(pars, is.null)] # remove NULL components
key[[i]] <- complete_names(key[[i]], pars, allow.invalid = TRUE)
pars[names(key[[i]])] <- key[[i]]
tmplen <- max(unlist(lapply(pars,length)))
max.length <- max(max.length, tmplen)
components[[length(components)+1]] <-
list(type = "points", pars = pars, length = tmplen)
}
}
number.of.components <- length(components)
## number of components named one of "text",
## "lines", "rectangles" or "points"
if (number.of.components == 0)
stop("Invalid key, need at least one component named lines, text, rect or points")
## The next part makes sure all components have same length,
## except text, which should be as long as the number of labels
## Update (9/11/2003): but that doesn't always make sense --- Re:
## r-help message from Alexander.Herr@csiro.au (though it seems
## that's S+ behaviour on Linux at least). Each component should
## be allowed to have its own length (that's what the lattice docs
## suggest too, don't know why). Anyway, I'm adding a rep = TRUE
## argument to the key list, which controls whether each column
## will be repeated as necessary to have the same length.
for (i in seq_len(number.of.components))
{
if (key$rep && (components[[i]]$type != "text"))
components[[i]]$length <- max.length
components[[i]]$pars <-
lapply(components[[i]]$pars, rep, length.out = components[[i]]$length)
if (key$reverse.rows)
components[[i]]$pars <-
lapply(components[[i]]$pars, rev)
## {
## if (key$rep) components[[i]]$length <- max.length
## components[[i]]$pars <-
## lapply(components[[i]]$pars, rep, components[[i]]$length)
## }
## else
## {
## components[[i]]$pars <-
## c(components[[i]]$pars[1],
## lapply(components[[i]]$pars[-1], rep,
## length.out = components[[i]]$length))
## }
}
column.blocks <- key$columns
rows.per.block <- ceiling(max.length/column.blocks)
if (column.blocks > max.length) warning("not enough rows for columns")
key$between <- rep(key$between, length.out = number.of.components)
if (key$align)
{
## Setting up the layout
## The problem of allocating space for text (character strings
## or expressions) is dealt with as follows:
## Each row and column will take exactly as much space as
## necessary. As steps in the construction, a matrix
## textMatrix (of same dimensions as the layout) will contain
## either 0, meaning that entry is not text, or n > 0, meaning
## that entry has the text given by textList[[n]], where
## textList is a list consisting of character strings or
## expressions.
n.row <- rows.per.block + 1
n.col <- column.blocks * (1 + 3 * number.of.components) - 1
textMatrix <- matrix(0, n.row, n.col)
textList <- list()
textCex <- numeric(0)
heights.x <- rep(1, n.row)
heights.units <- rep("lines", n.row)
heights.data <- vector(mode = "list", length = n.row)
if (length(key$title) > 0)
{
stopifnot(length(key$title) == 1,
is.characterOrExpression(key$title))
heights.x[1] <- key$lines.title * key$cex.title
heights.units[1] <- "strheight"
heights.data[[1]] <- key$title
titleWidth <-
unit(key$cex.title, "strwidth", data = list(key$title)) +
unit(key$between[[1]], "strwidth", data = list("o"))
}
else
{
heights.x[1] <- 0
titleWidth <- unit(0, "mm")
}
widths.x <- rep(key$between.columns, n.col)
widths.units <- rep("strwidth", n.col)
widths.data <- as.list(rep("o", n.col))
## FIXME: between is supposed to be in 'character widths'. Is
## there a better standard definition? Use "char" or "points"
## units?
for (i in 1:column.blocks)
{
widths.x[(1:number.of.components-1)*3+1 +
(i-1)*3*number.of.components + i-1] <-
key$between/2
widths.x[(1:number.of.components-1)*3+1 +
(i-1)*3*number.of.components + i+1] <-
key$between/2
}
index <- 1
for (i in 1:number.of.components)
{
cur <- components[[i]]
id <- (1:column.blocks - 1) *
(number.of.components * 3 + 1) + i * 3 - 1
if (cur$type == "text")
{
for (j in 1:cur$length)
{
colblck <- ceiling(j / rows.per.block)
xx <- (colblck - 1) *
(number.of.components * 3 + 1) + i * 3 - 1
yy <- j %% rows.per.block + 1
if (yy == 1) yy <- rows.per.block + 1
textMatrix[yy, xx] <- index
textList <- c(textList, list(cur$pars$labels[j]) )
textCex <- c(textCex, cur$pars$cex[j])
index <- index + 1
}
} ## FIXME: do the same as above for those below
else if (cur$type == "rectangles")
{
widths.x[id] <- max(cur$pars$size)
}
else if (cur$type == "lines")
{
widths.x[id] <- max(cur$pars$size)
}
else if (cur$type == "points")
{
widths.x[id] <- max(cur$pars$cex)
}
}
## Need to adjust the heights and widths
## adjusting heights
heights.insertlist.position <- 0
heights.insertlist.unit <- unit(1, "null")
for (i in seq_len(n.row))
{
textLocations <- textMatrix[i,]
if (any(textLocations > 0))
{
textLocations <- textLocations[textLocations>0]
strbar <- textList[textLocations]
heights.insertlist.position <- c(heights.insertlist.position, i)
heights.insertlist.unit <-
unit.c(heights.insertlist.unit,
unit(.2 * key$padding.text, "lines") +
max(unit(textCex[textLocations], "strheight", strbar)))
}
}
layout.heights <- unit(heights.x, heights.units, data=heights.data)
if (length(heights.insertlist.position)>1)
for (indx in 2:length(heights.insertlist.position))
layout.heights <-
rearrangeUnit(layout.heights, heights.insertlist.position[indx],
heights.insertlist.unit[indx])
## adjusting widths
widths.insertlist.position <- 0
widths.insertlist.unit <- unit(1, "null")
for (i in 1:n.col)
{
textLocations <- textMatrix[,i]
if (any(textLocations > 0))
{
textLocations <- textLocations[textLocations>0]
strbar <- textList[textLocations]
widths.insertlist.position <- c(widths.insertlist.position, i)
widths.insertlist.unit <-
unit.c(widths.insertlist.unit,
max(unit(textCex[textLocations], "strwidth", strbar)))
}
}
layout.widths <- unit(widths.x, widths.units, data=widths.data)
if (length(widths.insertlist.position)>1)
for (indx in 2:length(widths.insertlist.position))
layout.widths <-
rearrangeUnit(layout.widths, widths.insertlist.position[indx],
widths.insertlist.unit[indx])
key.layout <-
grid.layout(nrow = n.row, ncol = n.col,
widths = layout.widths,
heights = layout.heights,
respect = FALSE,
just = if (is.null(key$just)) "center" else key$just)
## OK, layout set up, now to draw the key - no
key.gf <- frameGrob(layout = key.layout, vp = vp,
name = trellis.grobname("frame", type="key"))
if (!key$transparent)
key.gf <-
placeGrob(key.gf,
rectGrob(gp = gpar(fill = key$background,
alpha = key$alpha.background,
col = key$border),
width = max(titleWidth, grobWidth(key.gf)),
name = trellis.grobname("background",
type="key")),
row = NULL, col = NULL)
else
key.gf <-
placeGrob(key.gf,
rectGrob(gp = gpar(col = key$border),
name = trellis.grobname("background",
type="key")),
row = NULL, col = NULL)
## Title (FIXME: allow color, font, alpha-transparency here?
if (!is.null(key$title))
key.gf <-
placeGrob(key.gf,
textGrob(label = key$title,
## x = 0,
gp = gpar(cex = key$cex.title,
lineheight = key$lineheight),
## just = "left",
name = trellis.grobname("title",
type="key")),
row = 1, col = NULL)
for (i in 1:number.of.components)
{
cur <- components[[i]]
for (j in seq_len(cur$length))
{
colblck <- ceiling(j / rows.per.block)
xx <- (colblck - 1) *
(number.of.components*3 + 1) + i*3 - 1
yy <- j %% rows.per.block + 1
if (yy == 1) yy <- rows.per.block + 1
componentx <- (colblck - 1)*(number.of.components) + i
componenty <- (j - 1) %% rows.per.block + 1
if (cur$type == "text")
{
key.gf <-
placeGrob(key.gf,
textGrob(x = cur$pars$adj[j],
hjust = cur$pars$adj[j],
## just = c(
## if (cur$pars$adj[j] == 1) "right"
## else if (cur$pars$adj[j] == 0) "left"
## else "center",
## "center"),
label = cur$pars$labels[j],
gp = gpar(col = cur$pars$col[j],
alpha = cur$pars$alpha[j],
lineheight = cur$pars$lineheight[j],
fontfamily = cur$pars$fontfamily[j],
fontface = chooseFace(cur$pars$fontface[j],
cur$pars$font[j]),
cex = cur$pars$cex[j]),
name = componentName("text",
componentx, componenty)),
row = yy, col = xx)
}
else if (cur$type == "rectangles")
{
key.gf <-
placeGrob(key.gf,
rectGrob(height = cur$pars$height[j],
width = cur$pars$size[j] / max(cur$pars$size),
default.units = "npc",
## centred, unlike S-PLUS, due to aesthetic reasons !
gp = gpar(alpha = cur$pars$alpha[j],
fill = cur$pars$col[j],
col = cur$pars$border[j]),
name = componentName("rect",
componentx, componenty)),
row = yy, col = xx)
## FIXME: Need to make changes to support angle/density
}
else if (cur$type == "lines")
{
if (cur$pars$type[j] == "l")
{
key.gf <-
placeGrob(key.gf,
linesGrob(x = c(0,1) * cur$pars$size[j] / max(cur$pars$size),
## ^^ FIXME: this
## should be centered
## as well, but since
## the chances that
## someone would
## actually use this
## feature are
## astronomically
## small, I'm leaving
## that for later.
y = c(.5, .5),
gp = gpar(col = cur$pars$col[j],
alpha = cur$pars$alpha[j],
lty = cur$pars$lty[j],
lwd = cur$pars$lwd[j]),
name = componentName("lines",
componentx, componenty)),
row = yy, col = xx)
}
else if (cur$pars$type[j] == "p")
{
key.gf <-
placeGrob(key.gf,
pointsGrob(x = 0.5, y = 0.5,
gp = gpar(col = cur$pars$col[j],
alpha = cur$pars$alpha[j],
cex = cur$pars$cex[j],
fill = cur$pars$fill[j],
fontfamily = cur$pars$fontfamily[j],
fontface = chooseFace(cur$pars$fontface[j],
cur$pars$font[j]),
fontsize = fontsize.points),
pch = cur$pars$pch[j],
name = componentName("points",
componentx, componenty)),
row = yy, col = xx)
}
else # if (cur$pars$type[j] == "b" or "o") -- not differentiating
{
key.gf <-
placeGrob(key.gf,
linesGrob(x = c(0,1) * cur$pars$size[j]/max(cur$pars$size),
## ^^ this should be
## centered as well,
## but since the
## chances that
## someone would
## actually use this
## feature are
## astronomical, I'm
## leaving that for
## later.
y = c(.5, .5),
gp = gpar(col = cur$pars$col[j],
alpha = cur$pars$alpha[j],
lty = cur$pars$lty[j],
lwd = cur$pars$lwd[j]),
name = componentName("lines",
componentx, componenty)),
row = yy, col = xx)
if (key$divide > 1)
{
key.gf <-
placeGrob(key.gf,
pointsGrob(x = (1:key$divide-1)/(key$divide-1),
y = rep(.5, key$divide),
gp = gpar(col = cur$pars$col[j],
alpha = cur$pars$alpha[j],
cex = cur$pars$cex[j],
fill = cur$pars$fill[j],
fontfamily = cur$pars$fontfamily[j],
fontface = chooseFace(cur$pars$fontface[j], cur$pars$font[j]),
fontsize = fontsize.points),
pch = cur$pars$pch[j],
name = componentName("points",
componentx, componenty)),
row = yy, col = xx)
}
else if (key$divide == 1)
{
key.gf <-
placeGrob(key.gf,
pointsGrob(x = 0.5,
y = 0.5,
gp = gpar(col = cur$pars$col[j],
alpha = cur$pars$alpha[j],
cex = cur$pars$cex[j],
fill = cur$pars$fill[j],
fontfamily = cur$pars$fontfamily[j],
fontface = chooseFace(cur$pars$fontface[j], cur$pars$font[j]),
fontsize = fontsize.points),
pch = cur$pars$pch[j],
name = componentName("points",
componentx, componenty)),
row = yy, col = xx)
}
}
}
else if (cur$type == "points")
{
key.gf <-
placeGrob(key.gf,
pointsGrob(x = 0.5, y = 0.5,
gp = gpar(col = cur$pars$col[j],
alpha = cur$pars$alpha[j],
cex = cur$pars$cex[j],
lwd = cur$pars$lwd[j],
fill = cur$pars$fill[j],
fontfamily = cur$pars$fontfamily[j],
fontface = chooseFace(cur$pars$fontface[j], cur$pars$font[j]),
fontsize = fontsize.points),
pch = cur$pars$pch[j],
name = componentName("points",
componentx, componenty)),
row = yy, col = xx)
}
}
}
}
else stop("Sorry, align=FALSE is not supported")
attr(key.gf, "titleWidth") <- titleWidth
class(key.gf) <- c("latticeKey", class(key.gf))
if (draw) grid.draw(key.gf)
key.gf
}
widthDetails.latticeKey <- function(x) {
max(NextMethod("widthDetails"),
attr(x, "titleWidth"))
}
draw.colorkey <- function(key, draw = FALSE, vp = NULL)
{
if (!is.list(key)) stop("key must be a list")
process.key <-
function(col = regions$col,
alpha = regions$alpha,
at,
tick.number = 7,
title = NULL,
title.control = list(padding = 1, side = NULL),
tck = 1,
width = 2,
height = 1,
space = "right",
raster = FALSE,
interpolate = FALSE,
tri.upper = NA,
tri.lower = NA,
axis.line = list(),
axis.text = list(),
...)
{
regions <- trellis.par.get("regions")
list(col = col,
alpha = alpha,
at = at,
tick.number = tick.number,
tck = tck,
title = title,
title.control = title.control,
width = width,
height = height,
space = space,
raster = raster,
interpolate = interpolate,
tri.upper = tri.upper,
tri.lower = tri.lower,
axis.line = axis.line,
axis.text = axis.text,
...)
}
key <- do.call(process.key, key)
axis.line <- updateList(trellis.par.get("axis.line"), key$axis.line)
axis.text <- updateList(trellis.par.get("axis.text"), key$axis.text)
## made FALSE later if labels explicitly specified
check.overlap <- TRUE
## Note: there are two 'at'-s here, one is key$at, which specifies
## the breakpoints of the rectangles, and the other is key$lab$at
## (optional) which is the positions of the ticks. We will use the
## 'at' variable for the latter, 'atrange' for the range of the
## former, and key$at explicitly when needed
## Getting the locations/dimensions/centers of the rectangles
key$at <- sort(key$at) ## should check if ordered
numcol <- length(key$at)-1
## numcol.r <- length(key$col)
## key$col <-
## if (is.function(key$col)) key$col(numcol)
## else if (numcol.r <= numcol) rep(key$col, length.out = numcol)
## else key$col[floor(1+(1:numcol-1)*(numcol.r-1)/(numcol-1))]
key$col <-
level.colors(x = seq_len(numcol) - 0.5,
at = seq_len(numcol + 1) - 1,
col.regions = key$col,
colors = TRUE)
## FIXME: need to handle DateTime classes properly
atrange <- range(key$at, finite = TRUE)
scat <- as.numeric(key$at) ## problems otherwise with DateTime objects (?)
if (key$raster && !isTRUE(all.equal(diff(range(diff(scat))), 0)))
warning("'at' values are not equispaced; output may be wrong")
## recnum <- length(scat)-1
reccentre <- (scat[-1] + scat[-length(scat)]) / 2
recdim <- diff(scat)
cex <- axis.text$cex
col <- axis.text$col
font <- axis.text$font
fontfamily <- axis.text$fontfamily
fontface <- axis.text$fontface
lineheight <- axis.text$lineheight
rot <- 0
## The following code assumes names key$lab and key$lab$lab (which
## may have been used in user code), whereas documentation says
## key$labels and key$labels$labels. To make both work without
## 'partial matching' warnings, we rename key$labels to key$lab
## etc.
if (!is.null(key[["labels"]]))
{
key[["lab"]] <- key[["labels"]]
key[["labels"]] <- NULL
if (is.list(key[["lab"]]) && !is.null(key[["lab"]][["labels"]]))
{
key[["lab"]][["lab"]] <- key[["lab"]][["labels"]]
key[["lab"]][["labels"]] <- NULL
}
}
if (is.null(key$lab))
{
at <- lpretty(atrange, key$tick.number)
at <- at[at >= atrange[1] & at <= atrange[2]]
labels <- format(at, trim = TRUE)
}
else if (is.characterOrExpression(key$lab) && length(key$lab)==length(key$at))
{
check.overlap <- FALSE
at <- key$at
labels <- key$lab
}
else if (is.list(key$lab))
{
at <- if (!is.null(key$lab$at)) key$lab$at else lpretty(atrange, key$tick.number)
labels <- if (!is.null(key$lab$lab)) {
if (is.null(key$lab$at))
stop("key specifies 'labels$labels' but not 'labels$at'", call. = FALSE)
if (length(key$lab$lab) != length(key$lab$at))
stop("lengths of key's 'labels$labels' and 'labels$at' differ", call. = FALSE)
check.overlap <- FALSE
key$lab$lab
} else format(at, trim = TRUE)
.include <- at >= atrange[1] & at <= atrange[2]
at <- at [.include]
labels <- labels[.include]
if (!is.null(key$lab$cex)) cex <- key$lab$cex
if (!is.null(key$lab$col)) col <- key$lab$col
if (!is.null(key$lab$font)) font <- key$lab$font
if (!is.null(key$lab$fontface)) fontface <- key$lab$fontface
if (!is.null(key$lab$fontfamily)) fontfamily <- key$lab$fontfamily
if (!is.null(key$lab$lineheight)) lineheight <- key$lab$lineheight
if (!is.null(key$lab$rot)) rot <- key$lab$rot
}
else stop("malformed colorkey")
labscat <- at
do.labels <- (length(labscat) > 0)
## title
if (!is.null(key$title))
{
## can have usual components like xlab etc
title <- getLabelList(key$title, trellis.par.get("par.title.text"))
title.control <- key$title.control
## title.control has additional parameters 'side' and 'padding'
if (is.null(title.control$side)) title.control$side <- key$space
if (is.null(title.control$padding)) title.control$padding <- 1
if (!is.grob(title) && is.null(title$rot))
title$rot <- switch(title.control$side, top=0, bottom=0, left=90, right=90)
title.grob <-
grobFromLabelList(title,
name = trellis.grobname("title", type="colorkey"))
}
## Setting 'open.lower' and 'open.upper' to non-zero makes
## colorkey end with triangular extensions, indicating open-ended
## intervals. Set to non-zero by default only if first/last
## intervals are unbounded (-Inf / +Inf). (NOTE: default should
## perhaps be 0 for back-compatibility, but currently these are
## simply not shown in the legend, so probably new behaviour is no
## worse). When non-zero, controls fraction of key$height to be
## used for triangles at ends.
convertTri <- function(x, inf = FALSE)
{
if (length(x) == 1)
{
if (is.na(x)) return(0.05 * inf)
else if (is.numeric(x) && (x >= 0 && x <= 0.25)) return(x)
else if (isTRUE(x)) return(0.05) else return(0)
}
warning("Invalid value of 'tri.upper/tri.lower' ignored.")
0
}
open.lower <- convertTri(key$tri.lower, scat[1] == -Inf)
open.upper <- convertTri(key$tri.upper, scat[length(scat)] == Inf)
key.rect <- 1 - open.lower - open.upper
gp.border <-
with(axis.line,
gpar(col = col, lty = lty, lwd = lwd, alpha = alpha,
fill = "transparent"))
if (key$space == "right")
{
labelsGrob <-
if (do.labels)
textGrob(label = labels,
x = rep(0, length(labscat)),
y = labscat,
vp = viewport(yscale = atrange),
default.units = "native",
check.overlap = check.overlap,
just = if (rot == -90) c("center", "bottom")
else c("left", "center"),
rot = rot,
name = trellis.grobname("labels", type="colorkey"),
gp =
gpar(col = col,
cex = cex,
fontfamily = fontfamily,
fontface = chooseFace(fontface, font),
lineheight = lineheight))
else nullGrob()
heights.x <- c(0.5 * (1 - key$height),
key$height * c(open.upper, key.rect, open.lower),
0.5 * (1 - key$height))
heights.units <- rep("null", 5)
widths.x <- c(0.6 * key$width, do.labels * (0.3 + key$tck * 0.3), do.labels * 1)
widths.units <- c("lines", "lines", "grobwidth")
widths.data <- list(NULL, NULL, labelsGrob)
key.layout <-
grid.layout(nrow = 5, ncol = 3,
heights = unit(heights.x, heights.units),
widths = unit(widths.x, widths.units, data = widths.data),
respect = TRUE)
key.gf <- frameGrob(layout = key.layout, vp = vp,
name = trellis.grobname("frame",
type="colorkey"))
if (key$raster)
{
key.gf <- placeGrob(key.gf,
rasterGrob(matrix(rev(key$col), ncol = 1),
width = 1, height = 1,
vp = viewport(clip = "on"),
name = trellis.grobname("raster",
type="colorkey"),
interpolate = key$interpolate),
row = 3, col = 1)
}
else
{
key.gf <- placeGrob(key.gf,
rectGrob(x = rep(.5, length(reccentre)),
y = reccentre,
default.units = "native",
vp = viewport(yscale = atrange),
height = recdim,
name = trellis.grobname("image",
type="colorkey"),
gp =
gpar(fill = key$col,
col = "transparent",
alpha = key$alpha)),
row = 3, col = 1)
}
if (open.lower > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(x = c(0, 1, 0.5),
y = c(1, 1, 0),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("lower.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[1],
col = "transparent",
alpha = key$alpha)),
row = 4, col = 1)
}
if (open.upper > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(x = c(0, 1, 0.5),
y = c(0, 0, 1),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("upper.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[length(key$col)],
col = "transparent",
alpha = key$alpha)),
row = 2, col = 1)
}
## borders
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 1), c(0, 0), c(0, 1), c(1, 1),
default.units = "npc",
name = trellis.grobname("border.sides", type="colorkey"),
gp = gp.border),
row = 3, col = 1)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 1), c(1, 1), c(0.5, 0.5), c(0, 0),
default.units = "npc",
name = trellis.grobname("border.lower", type="colorkey"),
gp = gp.border),
row = 4, col = 1)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 1), c(0, 0), c(0.5, 0.5), c(1, 1),
default.units = "npc",
name = trellis.grobname("border.upper", type="colorkey"),
gp = gp.border),
row = 2, col = 1)
## labels
if (do.labels)
{
if (key$tck != 0)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(x0 = rep(0, length(labscat)),
y0 = labscat,
x1 = rep(key$tck / (1 + key$tck), length(labscat)),
y1 = labscat,
vp = viewport(yscale = atrange),
default.units = "native",
name = trellis.grobname("ticks",
type="colorkey"),
gp =
gpar(col = axis.line$col,
lty = axis.line$lty,
lwd = axis.line$lwd)),
row = 3, col = 2)
key.gf <- placeGrob(key.gf,
labelsGrob,
row = 3, col = 3)
}
}
else if (key$space == "left")
{
labelsGrob <-
if (do.labels)
textGrob(label = labels,
x = rep(1, length(labscat)),
y = labscat,
vp = viewport(yscale = atrange),
default.units = "native",
check.overlap = check.overlap,
just = if (rot == 90) c("center", "bottom") else c("right", "center"),
rot = rot,
name = trellis.grobname("labels", type="colorkey"),
gp =
gpar(col = col,
cex = cex,
fontfamily = fontfamily,
fontface = chooseFace(fontface, font),
lineheight = lineheight))
else nullGrob()
heights.x <- c(0.5 * (1 - key$height),
key$height * c(open.upper, key.rect, open.lower),
0.5 * (1 - key$height))
heights.units <- rep("null", 5)
widths.x <- c(do.labels * 1, do.labels * (0.3 + key$tck * 0.3), 0.6 * key$width)
widths.units <- c("grobwidth", "lines", "lines")
widths.data <- list(labelsGrob, NULL, NULL)
key.layout <-
grid.layout(nrow = 5, ncol = 3,
heights = unit(heights.x, heights.units),
widths = unit(widths.x, widths.units, data = widths.data),
respect = TRUE)
key.gf <- frameGrob(layout = key.layout, vp = vp,
name = trellis.grobname("frame",
type="colorkey"))
if (key$raster)
{
key.gf <- placeGrob(key.gf,
rasterGrob(matrix(rev(key$col), ncol = 1),
width = 1, height = 1,
vp = viewport(clip = "on"),
name = trellis.grobname("raster",
type="colorkey"),
interpolate = key$interpolate),
row = 3, col = 3)
}
else
{
key.gf <- placeGrob(key.gf,
rectGrob(x = rep(.5, length(reccentre)),
y = reccentre,
default.units = "native",
vp = viewport(yscale = atrange),
height = recdim,
name = trellis.grobname("image",
type="colorkey"),
gp =
gpar(fill = key$col,
col = "transparent",
alpha = key$alpha)),
row = 3, col = 3)
}
if (open.lower > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(x = c(0, 1, 0.5),
y = c(1, 1, 0),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("lower.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[1],
col = "transparent",
alpha = key$alpha)),
row = 4, col = 3)
}
if (open.upper > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(x = c(0, 1, 0.5),
y = c(0, 0, 1),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("upper.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[length(key$col)],
col = "transparent",
alpha = key$alpha)),
row = 2, col = 3)
}
## borders
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 1), c(0, 0), c(0, 1), c(1, 1),
default.units = "npc",
name = trellis.grobname("border.sides", type="colorkey"),
gp = gp.border),
row = 3, col = 3)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 1), c(1, 1), c(0.5, 0.5), c(0, 0),
default.units = "npc",
name = trellis.grobname("border.lower", type="colorkey"),
gp = gp.border),
row = 4, col = 3)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 1), c(0, 0), c(0.5, 0.5), c(1, 1),
default.units = "npc",
name = trellis.grobname("border.upper", type="colorkey"),
gp = gp.border),
row = 2, col = 3)
## labels
if (do.labels)
{
if (key$tck != 0)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(x0 = rep(1, length(labscat)),
y0 = labscat,
x1 = rep(1 - key$tck / (1 + key$tck), length(labscat)),
y1 = labscat,
vp = viewport(yscale = atrange),
default.units = "native",
name = trellis.grobname("ticks",
type="colorkey"),
gp =
gpar(col = axis.line$col,
lty = axis.line$lty,
lwd = axis.line$lwd)),
row = 3, col = 2)
key.gf <- placeGrob(key.gf,
labelsGrob,
row = 3, col = 1)
}
}
else if (key$space == "top")
{
labelsGrob <-
if (do.labels)
textGrob(label = labels,
y = rep(0, length(labscat)),
x = labscat,
vp = viewport(xscale = atrange),
default.units = "native",
check.overlap = check.overlap,
just = if (rot == 0) c("center","bottom") else c("left", "center"),
rot = rot,
name = trellis.grobname("labels", type="colorkey"),
gp =
gpar(col = col,
cex = cex,
fontfamily = fontfamily,
fontface = chooseFace(fontface, font),
lineheight = lineheight))
else nullGrob()
widths.x <- c(0.5 * (1 - key$height),
key$height * c(open.lower, key.rect, open.upper),
0.5 * (1 - key$height))
widths.units <- rep("null", 5)
heights.x <- c(do.labels * 1, do.labels * (0.3 + key$tck * 0.3), 0.6 * key$width)
heights.units <- c("grobheight", "lines", "lines")
heights.data <- list(labelsGrob, NULL, NULL)
key.layout <-
grid.layout(nrow = 3, ncol = 5,
heights = unit(heights.x, heights.units, data = heights.data),
widths = unit(widths.x, widths.units),
respect = TRUE)
key.gf <- frameGrob(layout = key.layout, vp = vp,
name = trellis.grobname("frame",
type="colorkey"))
if (key$raster)
{
key.gf <- placeGrob(key.gf,
rasterGrob(matrix(key$col, nrow = 1),
width = 1, height = 1,
vp = viewport(clip = "on"),
name = trellis.grobname("raster",
type="colorkey"),
interpolate = key$interpolate),
row = 3, col = 3)
}
else
{
key.gf <- placeGrob(key.gf,
rectGrob(y = rep(.5, length(reccentre)),
x = reccentre,
default.units = "native",
vp = viewport(xscale = atrange),
width = recdim,
name = trellis.grobname("image",
type="colorkey"),
gp =
gpar(fill = key$col,
col = "transparent",
alpha = key$alpha)),
row = 3, col = 3)
}
if (open.lower > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(y = c(0, 1, 0.5),
x = c(1, 1, 0),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("lower.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[1],
col = "transparent",
alpha = key$alpha)),
row = 3, col = 2)
}
if (open.upper > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(y = c(0, 1, 0.5),
x = c(0, 0, 1),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("upper.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[length(key$col)],
col = "transparent",
alpha = key$alpha)),
row = 3, col = 4)
}
## borders
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 0), c(0, 1), c(1, 1), c(0, 1),
default.units = "npc",
name = trellis.grobname("border.sides", type="colorkey"),
gp = gp.border),
row = 3, col = 3)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(1, 1), c(0, 1), c(0, 0), c(0.5, 0.5),
default.units = "npc",
name = trellis.grobname("border.lower", type="colorkey"),
gp = gp.border),
row = 3, col = 2)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 0), c(0, 1), c(1, 1), c(0.5, 0.5),
default.units = "npc",
name = trellis.grobname("border.upper", type="colorkey"),
gp = gp.border),
row = 3, col = 4)
## labels
if (do.labels)
{
if (key$tck != 0)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(y0 = rep(0, length(labscat)),
x0 = labscat,
y1 = rep(key$tck / (1 + key$tck), length(labscat)),
x1 = labscat,
vp = viewport(xscale = atrange),
default.units = "native",
name = trellis.grobname("ticks",
type="colorkey"),
gp =
gpar(col = axis.line$col,
lty = axis.line$lty,
lwd = axis.line$lwd)),
row = 2, col = 3)
key.gf <- placeGrob(key.gf,
labelsGrob,
row = 1, col = 3)
}
}
else if (key$space == "bottom")
{
labelsGrob <-
if (do.labels)
textGrob(label = labels,
y = rep(1, length(labscat)),
x = labscat,
vp = viewport(xscale = atrange),
default.units = "native",
check.overlap = check.overlap,
just = if (rot == 0) c("center", "top") else c("right", "center"),
rot = rot,
name = trellis.grobname("labels", type="colorkey"),
gp =
gpar(col = col,
cex = cex,
fontfamily = fontfamily,
fontface = chooseFace(fontface, font),
lineheight = lineheight))
else nullGrob()
widths.x <- c(0.5 * (1 - key$height),
key$height * c(open.lower, key.rect, open.upper),
0.5 * (1 - key$height))
widths.units <- rep("null", 5)
heights.x <- c(0.6 * key$width, do.labels * (0.3 + key$tck * 0.3), do.labels * 1)
heights.units <- c("lines", "lines", "grobheight")
heights.data <- list(NULL, NULL, labelsGrob)
key.layout <-
grid.layout(nrow = 3, ncol = 5,
heights = unit(heights.x, heights.units, data = heights.data),
widths = unit(widths.x, widths.units),
respect = TRUE)
key.gf <- frameGrob(layout = key.layout, vp = vp,
name = trellis.grobname("frame",
type="colorkey"))
if (key$raster)
{
key.gf <- placeGrob(key.gf,
rasterGrob(matrix(key$col, nrow = 1),
width = 1, height = 1,
vp = viewport(clip = "on"),
name = trellis.grobname("raster",
type="colorkey"),
interpolate = key$interpolate),
row = 1, col = 3)
}
else
{
key.gf <- placeGrob(key.gf,
rectGrob(y = rep(.5, length(reccentre)),
x = reccentre,
default.units = "native",
vp = viewport(xscale = atrange),
width = recdim,
name = trellis.grobname("image",
type="colorkey"),
gp =
gpar(fill = key$col,
col = "transparent",
alpha = key$alpha)),
row = 1, col = 3)
}
if (open.lower > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(y = c(0, 1, 0.5),
x = c(1, 1, 0),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("lower.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[1],
col = "transparent",
alpha = key$alpha)),
row = 1, col = 2)
}
if (open.upper > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(y = c(0, 1, 0.5),
x = c(0, 0, 1),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("upper.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[length(key$col)],
col = "transparent",
alpha = key$alpha)),
row = 1, col = 4)
}
## borders
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 0), c(0, 1), c(1, 1), c(0, 1),
default.units = "npc",
name = trellis.grobname("border.sides", type="colorkey"),
gp = gp.border),
row = 1, col = 3)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(1, 1), c(0, 1), c(0, 0), c(0.5, 0.5),
default.units = "npc",
name = trellis.grobname("border.lower", type="colorkey"),
gp = gp.border),
row = 1, col = 2)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 0), c(0, 1), c(1, 1), c(0.5, 0.5),
default.units = "npc",
name = trellis.grobname("border.upper", type="colorkey"),
gp = gp.border),
row = 1, col = 4)
## labels
if (do.labels)
{
if (key$tck != 0)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(y0 = rep(1, length(labscat)),
x0 = labscat,
y1 = rep(1 - key$tck / (1 + key$tck), length(labscat)),
x1 = labscat,
vp = viewport(xscale = atrange),
default.units = "native",
name = trellis.grobname("ticks",
type="colorkey"),
gp =
gpar(col = axis.line$col,
lty = axis.line$lty,
lwd = axis.line$lwd)),
row = 2, col = 3)
key.gf <- placeGrob(key.gf,
labelsGrob,
row = 3, col = 3)
}
}
if (!is.null(key$title))
{
tside <- title.control$side
tpadding <- title.control$padding
if (getRversion() >= "4.0.1")
{
## This is nicer, but only works with grid >= 4.0.1.
## Eventually make unconditional if we depend on R >= 4.0.1
## padding unit is not customizable, but can be controlled
## by title$padding
upad <- unit(tpadding * 0.5, "char")
key.gf <-
switch(tside,
left = packGrob(packGrob(key.gf, nullGrob(), side = tside, width = upad),
title.grob, side = tside),
right = packGrob(packGrob(key.gf, nullGrob(), side = tside, width = upad),
title.grob, side = tside),
top = packGrob(packGrob(key.gf, nullGrob(), side = tside, height = upad),
title.grob, side = tside),
bottom = packGrob(packGrob(key.gf, nullGrob(), side = tside, height = upad),
title.grob, side = tside))
}
else
{
key.title.layout <-
switch(tside,
left = grid.layout(nrow = 1, ncol = 3,
heights = unit(1, "grobheight", list(key.gf)),
widths = unit(c(1, 0.5 * tpadding, 1), c("grobwidth", "char", "grobwidth"), list(title.grob, NULL, key.gf))),
right = grid.layout(nrow = 1, ncol = 3,
heights = unit(1, "grobheight", list(key.gf)),
widths = unit(c(1, 0.5 * tpadding, 1), c("grobwidth", "char", "grobwidth"), list(key.gf, NULL, title.grob))),
top = grid.layout(nrow = 3, ncol = 1,
heights = unit(c(1, 0.5 * tpadding, 1), c("grobheight", "char", "grobheight"), list(title.grob, NULL, key.gf)),
widths = unit(1, "grobwidth", list(key.gf))),
bottom = grid.layout(nrow = 3, ncol = 1,
heights = unit(c(1, 0.5 * tpadding, 1), c("grobheight", "char", "grobheight"), list(key.gf, NULL, title.grob)),
widths = unit(1, "grobwidth", list(key.gf))))
key.title.gf <- frameGrob(layout = key.title.layout, vp = vp,
name = trellis.grobname("titleframe",
type="colorkey"))
key.title.gf <-
switch(tside,
left = placeGrob(placeGrob(key.title.gf, key.gf, row = 1, col = 3), title.grob, row = 1, col = 1),
right = placeGrob(placeGrob(key.title.gf, key.gf, row = 1, col = 1), title.grob, row = 1, col = 3),
top = placeGrob(placeGrob(key.title.gf, key.gf, row = 3, col = 1), title.grob, row = 1, col = 1),
bottom = placeGrob(placeGrob(key.title.gf, key.gf, row = 1, col = 1), title.grob, row = 3, col = 1))
key.gf <- key.title.gf
}
}
if (draw)
grid.draw(key.gf)
key.gf
}
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 draw.colorkey widthDetails.latticeKey draw.key componentName simpleKey drawSimpleKey autoKeyLegend defaultLegendPosition needAutoKey construct.legend
Documented in draw.colorkey draw.key simpleKey
### 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
construct.legend <-
function(legend = NULL, key = NULL, fun = "draw.key")
{
if (is.null(legend) && is.null(key)) return(NULL)
if (is.null(legend)) legend <- list()
if (!is.null(key))
{
space <- key$space
x <- y <- corner <- NULL
if (is.null(space))
{
if (any(c("x", "y", "corner") %in% names(key)))
{
stopifnot(is.null(x) || (length(x) == 1 && x >= 0 && x <= 1))
stopifnot(is.null(y) || (length(y) == 1 && y >= 0 && y <= 1))
stopifnot(is.null(corner) ||
(length(corner) == 2 &&
all(corner %in% c(0, 1))))
space <- "inside"
x <- key$x
y <- key$y
corner <- key$corner
## check for valid values
}
else
space <- "top"
}
if (space != "inside" && space %in% names(legend))
stop(gettextf("component '%s' duplicated in key and legend", space))
key.legend <- list(fun = fun, args = list(key = key, draw = FALSE))
key.legend$x <- x
key.legend$y <- y
key.legend$corner <- corner
legend <- c(list(key.legend), legend)
names(legend)[1] <- space
}
legend
}
## A convenience function for deciding whether an ``automatic'' legend
## should be drawn following instructions contained in the 'auto.key'
## argument.
needAutoKey <- function(auto.key, groups = NULL)
{
((!is.null(groups) && (isTRUE(auto.key) || is.list(auto.key))) ||
(is.list(auto.key) && !is.null(auto.key$text)))
## old behaviour was:
## !is.null(groups) && (is.list(auto.key) || isTRUE(auto.key))
}
## Pick a position for the legend based on its contents. Mainly used
## for 'auto.key' via 'drawSimpleKey()'. Explicit 'space' is honored
## in preference to anything else, otherwise 'right', unless 'columns
## > 1'.
defaultLegendPosition <- function(x)
{
if (!is.null(x$space)) return(x$space)
if (any(c("x", "y", "corner") %in% names(x))) "inside"
else if (!is.null(x$columns) && any(x$columns > 1)) "top"
else "right"
}
autoKeyLegend <- function(args, more)
{
if (is.list(more)) args <- updateList(args, more)
legend <- list(list(fun = "drawSimpleKey", args = args))
## These should be missing rather than NULL, so assigned separately
legend[[1]]$x <- legend[[1]]$args$x
legend[[1]]$y <- legend[[1]]$args$y
legend[[1]]$corner <- legend[[1]]$args$corner
names(legend) <- defaultLegendPosition(legend[[1]]$args)
legend
}
## convenience function for auto.key
drawSimpleKey <- function(...)
draw.key(simpleKey(...), draw = FALSE)
## convenience function for the most common type of key
simpleKey <-
function(text, points = TRUE,
rectangles = FALSE,
lines = FALSE,
col = add.text$col,
cex = add.text$cex,
alpha = add.text$alpha,
font = add.text$font,
fontface = add.text$fontface,
fontfamily = add.text$fontfamily,
lineheight = add.text$lineheight,
...)
{
add.text <- trellis.par.get("add.text")
foo <- seq_along(text)
ans <-
list(text = list(lab = text),
col = col, cex = cex, alpha = alpha,
font = font,
fontface = fontface,
fontfamily = fontfamily,
...)
if (points) ans$points <-
Rows(trellis.par.get("superpose.symbol"), foo)
if (rectangles) ans$rectangles <-
Rows(trellis.par.get("superpose.polygon"), foo)
if (lines) ans$lines <-
updateList(Rows(trellis.par.get("superpose.symbol"), foo), ## for pch
Rows(trellis.par.get("superpose.line"), foo))
ans
}
componentName <- function(name, x, y) {
trellis.grobname(paste(name, x, y, sep="."), type="key")
}
draw.key <- function(key, draw = FALSE, vp = NULL, ...)
{
if (!is.list(key)) stop("key must be a list")
max.length <- 0
## maximum of the `row-lengths' of the above
## components. There is some scope for confusion
## here, e.g., if col is specified in key as a
## length 6 vector, and then lines=list(lty=1:3),
## what should be the length of that lines column ?
## If 3, what happens if lines=list() ?
## (Strangely enough, S+ accepts lines=list()
## if col (etc) is NOT specified outside, but not
## if it is)
process.key <-
function(reverse.rows = FALSE, ## invert rows (e.g. for barchart, stack = FALSE)
between = 2,
align = TRUE,
title = NULL,
rep = TRUE,
background = trellis.par.get("background")$col,
alpha.background = 1,
border = FALSE,
transparent = FALSE,
col = "black",
alpha = 1,
lty = 1,
lwd = 1,
font = 1,
fontface = NULL,
fontfamily = NULL,
pch = 8,
cex = 1,
fill = "transparent",
adj = 0,
type = "l",
size = 5,
height = 1,
angle = 0,
density = -1,
cex.title = 1.5 * max(cex),
padding.text = 1,
lineheight = 1,
columns = 1,
divide = 3,
between.columns = 3,
## to avoid partial matching, anything starting with
## lines, points, rect, text must come after ...
...,
lines.title = 2)
{
list(reverse.rows = reverse.rows,
between = between,
align = align,
title = title,
rep = rep,
background = background,
alpha.background = alpha.background,
border = border,
transparent = transparent,
col = col,
alpha = alpha,
lty = lty,
lwd = lwd,
font = font,
fontface = fontface,
fontfamily = fontfamily,
pch = pch,
cex = cex,
fill = fill,
adj = adj,
type = type,
size = size,
height = height,
angle = angle,
density = density,
cex.title = cex.title,
padding.text = padding.text,
lineheight = lineheight,
columns = columns,
divide = divide,
between.columns = between.columns,
lines.title = lines.title,
...)
}
fontsize.points <- trellis.par.get("fontsize")$points
key <- do.call(process.key, key, quote = TRUE)
key.length <- length(key)
key.names <- names(key) # Need to update
if (is.logical(key$border))
key$border <-
if (key$border) "black"
else "transparent"
components <- list()
for(i in 1:key.length)
{
curname <- pmatch(key.names[i], c("text", "rectangles", "lines", "points"))
if (is.na(curname))
{
;## do nothing
}
else if (curname == 1) # "text"
{
if (!(is.characterOrExpression(key[[i]][[1]])))
stop("first component of text must be vector of labels")
pars <-
list(labels = key[[i]][[1]],
col = key$col,
alpha = key$alpha,
adj = key$adj,
cex = key$cex,
lineheight = key$lineheight,
font = key$font,
fontface = key$fontface,
fontfamily = key$fontfamily)
pars <- pars[!sapply(pars, is.null)] # remove NULL components
key[[i]][[1]] <- NULL
key[[i]] <- complete_names(key[[i]], pars, allow.invalid = TRUE)
pars[names(key[[i]])] <- key[[i]]
tmplen <- length(pars$labels)
for (j in 1:length(pars))
if (is.character(pars))
pars[[j]] <- rep(pars[[j]], length.out = tmplen)
max.length <- max(max.length, tmplen)
components[[length(components)+1]] <-
list(type = "text", pars = pars, length = tmplen)
}
else if (curname == 2) # "rectangles"
{
pars <-
list(col = key$col,
border = "black",
alpha = key$alpha,
size = key$size,
height = key$height,
angle = key$angle,
density = key$density)
pars <- pars[!sapply(pars, is.null)] # remove NULL components
key[[i]] <- complete_names(key[[i]], pars, allow.invalid = TRUE)
pars[names(key[[i]])] <- key[[i]]
tmplen <- max(unlist(lapply(pars,length)))
max.length <- max(max.length, tmplen)
components[[length(components)+1]] <-
list(type = "rectangles", pars = pars, length = tmplen)
}
else if (curname == 3) # "lines"
{
pars <-
list(col = key$col,
alpha = key$alpha,
size = key$size,
lty = key$lty,
cex = key$cex,
pch = key$pch,
fill = key$fill,
lwd = key$lwd,
type = key$type)
pars <- pars[!sapply(pars, is.null)] # remove NULL components
key[[i]] <- complete_names(key[[i]], pars, allow.invalid = TRUE)
pars[names(key[[i]])] <- key[[i]]
tmplen <- max(unlist(lapply(pars,length)))
max.length <- max(max.length, tmplen)
components[[length(components)+1]] <-
list(type = "lines", pars = pars, length = tmplen)
}
else if (curname == 4) # "points"
{
pars <-
list(col = key$col,
alpha = key$alpha,
cex = key$cex,
pch = key$pch,
lwd = key$lwd,
fill = key$fill,
font = key$font,
fontface = key$fontface,
fontfamily = key$fontfamily)
pars <- pars[!sapply(pars, is.null)] # remove NULL components
key[[i]] <- complete_names(key[[i]], pars, allow.invalid = TRUE)
pars[names(key[[i]])] <- key[[i]]
tmplen <- max(unlist(lapply(pars,length)))
max.length <- max(max.length, tmplen)
components[[length(components)+1]] <-
list(type = "points", pars = pars, length = tmplen)
}
}
number.of.components <- length(components)
## number of components named one of "text",
## "lines", "rectangles" or "points"
if (number.of.components == 0)
stop("Invalid key, need at least one component named lines, text, rect or points")
## The next part makes sure all components have same length,
## except text, which should be as long as the number of labels
## Update (9/11/2003): but that doesn't always make sense --- Re:
## r-help message from Alexander.Herr@csiro.au (though it seems
## that's S+ behaviour on Linux at least). Each component should
## be allowed to have its own length (that's what the lattice docs
## suggest too, don't know why). Anyway, I'm adding a rep = TRUE
## argument to the key list, which controls whether each column
## will be repeated as necessary to have the same length.
for (i in seq_len(number.of.components))
{
if (key$rep && (components[[i]]$type != "text"))
components[[i]]$length <- max.length
components[[i]]$pars <-
lapply(components[[i]]$pars, rep, length.out = components[[i]]$length)
if (key$reverse.rows)
components[[i]]$pars <-
lapply(components[[i]]$pars, rev)
## {
## if (key$rep) components[[i]]$length <- max.length
## components[[i]]$pars <-
## lapply(components[[i]]$pars, rep, components[[i]]$length)
## }
## else
## {
## components[[i]]$pars <-
## c(components[[i]]$pars[1],
## lapply(components[[i]]$pars[-1], rep,
## length.out = components[[i]]$length))
## }
}
column.blocks <- key$columns
rows.per.block <- ceiling(max.length/column.blocks)
if (column.blocks > max.length) warning("not enough rows for columns")
key$between <- rep(key$between, length.out = number.of.components)
if (key$align)
{
## Setting up the layout
## The problem of allocating space for text (character strings
## or expressions) is dealt with as follows:
## Each row and column will take exactly as much space as
## necessary. As steps in the construction, a matrix
## textMatrix (of same dimensions as the layout) will contain
## either 0, meaning that entry is not text, or n > 0, meaning
## that entry has the text given by textList[[n]], where
## textList is a list consisting of character strings or
## expressions.
n.row <- rows.per.block + 1
n.col <- column.blocks * (1 + 3 * number.of.components) - 1
textMatrix <- matrix(0, n.row, n.col)
textList <- list()
textCex <- numeric(0)
heights.x <- rep(1, n.row)
heights.units <- rep("lines", n.row)
heights.data <- vector(mode = "list", length = n.row)
if (length(key$title) > 0)
{
stopifnot(length(key$title) == 1,
is.characterOrExpression(key$title))
heights.x[1] <- key$lines.title * key$cex.title
heights.units[1] <- "strheight"
heights.data[[1]] <- key$title
titleWidth <-
unit(key$cex.title, "strwidth", data = list(key$title)) +
unit(key$between[[1]], "strwidth", data = list("o"))
}
else
{
heights.x[1] <- 0
titleWidth <- unit(0, "mm")
}
widths.x <- rep(key$between.columns, n.col)
widths.units <- rep("strwidth", n.col)
widths.data <- as.list(rep("o", n.col))
## FIXME: between is supposed to be in 'character widths'. Is
## there a better standard definition? Use "char" or "points"
## units?
for (i in 1:column.blocks)
{
widths.x[(1:number.of.components-1)*3+1 +
(i-1)*3*number.of.components + i-1] <-
key$between/2
widths.x[(1:number.of.components-1)*3+1 +
(i-1)*3*number.of.components + i+1] <-
key$between/2
}
index <- 1
for (i in 1:number.of.components)
{
cur <- components[[i]]
id <- (1:column.blocks - 1) *
(number.of.components * 3 + 1) + i * 3 - 1
if (cur$type == "text")
{
for (j in 1:cur$length)
{
colblck <- ceiling(j / rows.per.block)
xx <- (colblck - 1) *
(number.of.components * 3 + 1) + i * 3 - 1
yy <- j %% rows.per.block + 1
if (yy == 1) yy <- rows.per.block + 1
textMatrix[yy, xx] <- index
textList <- c(textList, list(cur$pars$labels[j]) )
textCex <- c(textCex, cur$pars$cex[j])
index <- index + 1
}
} ## FIXME: do the same as above for those below
else if (cur$type == "rectangles")
{
widths.x[id] <- max(cur$pars$size)
}
else if (cur$type == "lines")
{
widths.x[id] <- max(cur$pars$size)
}
else if (cur$type == "points")
{
widths.x[id] <- max(cur$pars$cex)
}
}
## Need to adjust the heights and widths
## adjusting heights
heights.insertlist.position <- 0
heights.insertlist.unit <- unit(1, "null")
for (i in seq_len(n.row))
{
textLocations <- textMatrix[i,]
if (any(textLocations > 0))
{
textLocations <- textLocations[textLocations>0]
strbar <- textList[textLocations]
heights.insertlist.position <- c(heights.insertlist.position, i)
heights.insertlist.unit <-
unit.c(heights.insertlist.unit,
unit(.2 * key$padding.text, "lines") +
max(unit(textCex[textLocations], "strheight", strbar)))
}
}
layout.heights <- unit(heights.x, heights.units, data=heights.data)
if (length(heights.insertlist.position)>1)
for (indx in 2:length(heights.insertlist.position))
layout.heights <-
rearrangeUnit(layout.heights, heights.insertlist.position[indx],
heights.insertlist.unit[indx])
## adjusting widths
widths.insertlist.position <- 0
widths.insertlist.unit <- unit(1, "null")
for (i in 1:n.col)
{
textLocations <- textMatrix[,i]
if (any(textLocations > 0))
{
textLocations <- textLocations[textLocations>0]
strbar <- textList[textLocations]
widths.insertlist.position <- c(widths.insertlist.position, i)
widths.insertlist.unit <-
unit.c(widths.insertlist.unit,
max(unit(textCex[textLocations], "strwidth", strbar)))
}
}
layout.widths <- unit(widths.x, widths.units, data=widths.data)
if (length(widths.insertlist.position)>1)
for (indx in 2:length(widths.insertlist.position))
layout.widths <-
rearrangeUnit(layout.widths, widths.insertlist.position[indx],
widths.insertlist.unit[indx])
key.layout <-
grid.layout(nrow = n.row, ncol = n.col,
widths = layout.widths,
heights = layout.heights,
respect = FALSE,
just = if (is.null(key$just)) "center" else key$just)
## OK, layout set up, now to draw the key - no
key.gf <- frameGrob(layout = key.layout, vp = vp,
name = trellis.grobname("frame", type="key"))
if (!key$transparent)
key.gf <-
placeGrob(key.gf,
rectGrob(gp = gpar(fill = key$background,
alpha = key$alpha.background,
col = key$border),
width = max(titleWidth, grobWidth(key.gf)),
name = trellis.grobname("background",
type="key")),
row = NULL, col = NULL)
else
key.gf <-
placeGrob(key.gf,
rectGrob(gp = gpar(col = key$border),
name = trellis.grobname("background",
type="key")),
row = NULL, col = NULL)
## Title (FIXME: allow color, font, alpha-transparency here?
if (!is.null(key$title))
key.gf <-
placeGrob(key.gf,
textGrob(label = key$title,
## x = 0,
gp = gpar(cex = key$cex.title,
lineheight = key$lineheight),
## just = "left",
name = trellis.grobname("title",
type="key")),
row = 1, col = NULL)
for (i in 1:number.of.components)
{
cur <- components[[i]]
for (j in seq_len(cur$length))
{
colblck <- ceiling(j / rows.per.block)
xx <- (colblck - 1) *
(number.of.components*3 + 1) + i*3 - 1
yy <- j %% rows.per.block + 1
if (yy == 1) yy <- rows.per.block + 1
componentx <- (colblck - 1)*(number.of.components) + i
componenty <- (j - 1) %% rows.per.block + 1
if (cur$type == "text")
{
key.gf <-
placeGrob(key.gf,
textGrob(x = cur$pars$adj[j],
hjust = cur$pars$adj[j],
## just = c(
## if (cur$pars$adj[j] == 1) "right"
## else if (cur$pars$adj[j] == 0) "left"
## else "center",
## "center"),
label = cur$pars$labels[j],
gp = gpar(col = cur$pars$col[j],
alpha = cur$pars$alpha[j],
lineheight = cur$pars$lineheight[j],
fontfamily = cur$pars$fontfamily[j],
fontface = chooseFace(cur$pars$fontface[j],
cur$pars$font[j]),
cex = cur$pars$cex[j]),
name = componentName("text",
componentx, componenty)),
row = yy, col = xx)
}
else if (cur$type == "rectangles")
{
key.gf <-
placeGrob(key.gf,
rectGrob(height = cur$pars$height[j],
width = cur$pars$size[j] / max(cur$pars$size),
default.units = "npc",
## centred, unlike S-PLUS, due to aesthetic reasons !
gp = gpar(alpha = cur$pars$alpha[j],
fill = cur$pars$col[j],
col = cur$pars$border[j]),
name = componentName("rect",
componentx, componenty)),
row = yy, col = xx)
## FIXME: Need to make changes to support angle/density
}
else if (cur$type == "lines")
{
if (cur$pars$type[j] == "l")
{
key.gf <-
placeGrob(key.gf,
linesGrob(x = c(0,1) * cur$pars$size[j] / max(cur$pars$size),
## ^^ FIXME: this
## should be centered
## as well, but since
## the chances that
## someone would
## actually use this
## feature are
## astronomically
## small, I'm leaving
## that for later.
y = c(.5, .5),
gp = gpar(col = cur$pars$col[j],
alpha = cur$pars$alpha[j],
lty = cur$pars$lty[j],
lwd = cur$pars$lwd[j]),
name = componentName("lines",
componentx, componenty)),
row = yy, col = xx)
}
else if (cur$pars$type[j] == "p")
{
key.gf <-
placeGrob(key.gf,
pointsGrob(x = 0.5, y = 0.5,
gp = gpar(col = cur$pars$col[j],
alpha = cur$pars$alpha[j],
cex = cur$pars$cex[j],
fill = cur$pars$fill[j],
fontfamily = cur$pars$fontfamily[j],
fontface = chooseFace(cur$pars$fontface[j],
cur$pars$font[j]),
fontsize = fontsize.points),
pch = cur$pars$pch[j],
name = componentName("points",
componentx, componenty)),
row = yy, col = xx)
}
else # if (cur$pars$type[j] == "b" or "o") -- not differentiating
{
key.gf <-
placeGrob(key.gf,
linesGrob(x = c(0,1) * cur$pars$size[j]/max(cur$pars$size),
## ^^ this should be
## centered as well,
## but since the
## chances that
## someone would
## actually use this
## feature are
## astronomical, I'm
## leaving that for
## later.
y = c(.5, .5),
gp = gpar(col = cur$pars$col[j],
alpha = cur$pars$alpha[j],
lty = cur$pars$lty[j],
lwd = cur$pars$lwd[j]),
name = componentName("lines",
componentx, componenty)),
row = yy, col = xx)
if (key$divide > 1)
{
key.gf <-
placeGrob(key.gf,
pointsGrob(x = (1:key$divide-1)/(key$divide-1),
y = rep(.5, key$divide),
gp = gpar(col = cur$pars$col[j],
alpha = cur$pars$alpha[j],
cex = cur$pars$cex[j],
fill = cur$pars$fill[j],
fontfamily = cur$pars$fontfamily[j],
fontface = chooseFace(cur$pars$fontface[j], cur$pars$font[j]),
fontsize = fontsize.points),
pch = cur$pars$pch[j],
name = componentName("points",
componentx, componenty)),
row = yy, col = xx)
}
else if (key$divide == 1)
{
key.gf <-
placeGrob(key.gf,
pointsGrob(x = 0.5,
y = 0.5,
gp = gpar(col = cur$pars$col[j],
alpha = cur$pars$alpha[j],
cex = cur$pars$cex[j],
fill = cur$pars$fill[j],
fontfamily = cur$pars$fontfamily[j],
fontface = chooseFace(cur$pars$fontface[j], cur$pars$font[j]),
fontsize = fontsize.points),
pch = cur$pars$pch[j],
name = componentName("points",
componentx, componenty)),
row = yy, col = xx)
}
}
}
else if (cur$type == "points")
{
key.gf <-
placeGrob(key.gf,
pointsGrob(x = 0.5, y = 0.5,
gp = gpar(col = cur$pars$col[j],
alpha = cur$pars$alpha[j],
cex = cur$pars$cex[j],
lwd = cur$pars$lwd[j],
fill = cur$pars$fill[j],
fontfamily = cur$pars$fontfamily[j],
fontface = chooseFace(cur$pars$fontface[j], cur$pars$font[j]),
fontsize = fontsize.points),
pch = cur$pars$pch[j],
name = componentName("points",
componentx, componenty)),
row = yy, col = xx)
}
}
}
}
else stop("Sorry, align=FALSE is not supported")
attr(key.gf, "titleWidth") <- titleWidth
class(key.gf) <- c("latticeKey", class(key.gf))
if (draw) grid.draw(key.gf)
key.gf
}
widthDetails.latticeKey <- function(x) {
max(NextMethod("widthDetails"),
attr(x, "titleWidth"))
}
draw.colorkey <- function(key, draw = FALSE, vp = NULL)
{
if (!is.list(key)) stop("key must be a list")
process.key <-
function(col = regions$col,
alpha = regions$alpha,
at,
tick.number = 7,
title = NULL,
title.control = list(padding = 1, side = NULL),
tck = 1,
width = 2,
height = 1,
space = "right",
raster = FALSE,
interpolate = FALSE,
tri.upper = NA,
tri.lower = NA,
axis.line = list(),
axis.text = list(),
...)
{
regions <- trellis.par.get("regions")
list(col = col,
alpha = alpha,
at = at,
tick.number = tick.number,
tck = tck,
title = title,
title.control = title.control,
width = width,
height = height,
space = space,
raster = raster,
interpolate = interpolate,
tri.upper = tri.upper,
tri.lower = tri.lower,
axis.line = axis.line,
axis.text = axis.text,
...)
}
key <- do.call(process.key, key)
axis.line <- updateList(trellis.par.get("axis.line"), key$axis.line)
axis.text <- updateList(trellis.par.get("axis.text"), key$axis.text)
## made FALSE later if labels explicitly specified
check.overlap <- TRUE
## Note: there are two 'at'-s here, one is key$at, which specifies
## the breakpoints of the rectangles, and the other is key$lab$at
## (optional) which is the positions of the ticks. We will use the
## 'at' variable for the latter, 'atrange' for the range of the
## former, and key$at explicitly when needed
## Getting the locations/dimensions/centers of the rectangles
key$at <- sort(key$at) ## should check if ordered
numcol <- length(key$at)-1
## numcol.r <- length(key$col)
## key$col <-
## if (is.function(key$col)) key$col(numcol)
## else if (numcol.r <= numcol) rep(key$col, length.out = numcol)
## else key$col[floor(1+(1:numcol-1)*(numcol.r-1)/(numcol-1))]
key$col <-
level.colors(x = seq_len(numcol) - 0.5,
at = seq_len(numcol + 1) - 1,
col.regions = key$col,
colors = TRUE)
## FIXME: need to handle DateTime classes properly
atrange <- range(key$at, finite = TRUE)
scat <- as.numeric(key$at) ## problems otherwise with DateTime objects (?)
if (key$raster && !isTRUE(all.equal(diff(range(diff(scat))), 0)))
warning("'at' values are not equispaced; output may be wrong")
## recnum <- length(scat)-1
reccentre <- (scat[-1] + scat[-length(scat)]) / 2
recdim <- diff(scat)
cex <- axis.text$cex
col <- axis.text$col
font <- axis.text$font
fontfamily <- axis.text$fontfamily
fontface <- axis.text$fontface
lineheight <- axis.text$lineheight
rot <- 0
## The following code assumes names key$lab and key$lab$lab (which
## may have been used in user code), whereas documentation says
## key$labels and key$labels$labels. To make both work without
## 'partial matching' warnings, we rename key$labels to key$lab
## etc.
if (!is.null(key[["labels"]]))
{
key[["lab"]] <- key[["labels"]]
key[["labels"]] <- NULL
if (is.list(key[["lab"]]) && !is.null(key[["lab"]][["labels"]]))
{
key[["lab"]][["lab"]] <- key[["lab"]][["labels"]]
key[["lab"]][["labels"]] <- NULL
}
}
if (is.null(key$lab))
{
at <- lpretty(atrange, key$tick.number)
at <- at[at >= atrange[1] & at <= atrange[2]]
labels <- format(at, trim = TRUE)
}
else if (is.characterOrExpression(key$lab) && length(key$lab)==length(key$at))
{
check.overlap <- FALSE
at <- key$at
labels <- key$lab
}
else if (is.list(key$lab))
{
at <- if (!is.null(key$lab$at)) key$lab$at else lpretty(atrange, key$tick.number)
labels <- if (!is.null(key$lab$lab)) {
if (is.null(key$lab$at))
stop("key specifies 'labels$labels' but not 'labels$at'", call. = FALSE)
if (length(key$lab$lab) != length(key$lab$at))
stop("lengths of key's 'labels$labels' and 'labels$at' differ", call. = FALSE)
check.overlap <- FALSE
key$lab$lab
} else format(at, trim = TRUE)
.include <- at >= atrange[1] & at <= atrange[2]
at <- at [.include]
labels <- labels[.include]
if (!is.null(key$lab$cex)) cex <- key$lab$cex
if (!is.null(key$lab$col)) col <- key$lab$col
if (!is.null(key$lab$font)) font <- key$lab$font
if (!is.null(key$lab$fontface)) fontface <- key$lab$fontface
if (!is.null(key$lab$fontfamily)) fontfamily <- key$lab$fontfamily
if (!is.null(key$lab$lineheight)) lineheight <- key$lab$lineheight
if (!is.null(key$lab$rot)) rot <- key$lab$rot
}
else stop("malformed colorkey")
labscat <- at
do.labels <- (length(labscat) > 0)
## title
if (!is.null(key$title))
{
## can have usual components like xlab etc
title <- getLabelList(key$title, trellis.par.get("par.title.text"))
title.control <- key$title.control
## title.control has additional parameters 'side' and 'padding'
if (is.null(title.control$side)) title.control$side <- key$space
if (is.null(title.control$padding)) title.control$padding <- 1
if (!is.grob(title) && is.null(title$rot))
title$rot <- switch(title.control$side, top=0, bottom=0, left=90, right=90)
title.grob <-
grobFromLabelList(title,
name = trellis.grobname("title", type="colorkey"))
}
## Setting 'open.lower' and 'open.upper' to non-zero makes
## colorkey end with triangular extensions, indicating open-ended
## intervals. Set to non-zero by default only if first/last
## intervals are unbounded (-Inf / +Inf). (NOTE: default should
## perhaps be 0 for back-compatibility, but currently these are
## simply not shown in the legend, so probably new behaviour is no
## worse). When non-zero, controls fraction of key$height to be
## used for triangles at ends.
convertTri <- function(x, inf = FALSE)
{
if (length(x) == 1)
{
if (is.na(x)) return(0.05 * inf)
else if (is.numeric(x) && (x >= 0 && x <= 0.25)) return(x)
else if (isTRUE(x)) return(0.05) else return(0)
}
warning("Invalid value of 'tri.upper/tri.lower' ignored.")
0
}
open.lower <- convertTri(key$tri.lower, scat[1] == -Inf)
open.upper <- convertTri(key$tri.upper, scat[length(scat)] == Inf)
key.rect <- 1 - open.lower - open.upper
gp.border <-
with(axis.line,
gpar(col = col, lty = lty, lwd = lwd, alpha = alpha,
fill = "transparent"))
if (key$space == "right")
{
labelsGrob <-
if (do.labels)
textGrob(label = labels,
x = rep(0, length(labscat)),
y = labscat,
vp = viewport(yscale = atrange),
default.units = "native",
check.overlap = check.overlap,
just = if (rot == -90) c("center", "bottom")
else c("left", "center"),
rot = rot,
name = trellis.grobname("labels", type="colorkey"),
gp =
gpar(col = col,
cex = cex,
fontfamily = fontfamily,
fontface = chooseFace(fontface, font),
lineheight = lineheight))
else nullGrob()
heights.x <- c(0.5 * (1 - key$height),
key$height * c(open.upper, key.rect, open.lower),
0.5 * (1 - key$height))
heights.units <- rep("null", 5)
widths.x <- c(0.6 * key$width, do.labels * (0.3 + key$tck * 0.3), do.labels * 1)
widths.units <- c("lines", "lines", "grobwidth")
widths.data <- list(NULL, NULL, labelsGrob)
key.layout <-
grid.layout(nrow = 5, ncol = 3,
heights = unit(heights.x, heights.units),
widths = unit(widths.x, widths.units, data = widths.data),
respect = TRUE)
key.gf <- frameGrob(layout = key.layout, vp = vp,
name = trellis.grobname("frame",
type="colorkey"))
if (key$raster)
{
key.gf <- placeGrob(key.gf,
rasterGrob(matrix(rev(key$col), ncol = 1),
width = 1, height = 1,
vp = viewport(clip = "on"),
name = trellis.grobname("raster",
type="colorkey"),
interpolate = key$interpolate),
row = 3, col = 1)
}
else
{
key.gf <- placeGrob(key.gf,
rectGrob(x = rep(.5, length(reccentre)),
y = reccentre,
default.units = "native",
vp = viewport(yscale = atrange),
height = recdim,
name = trellis.grobname("image",
type="colorkey"),
gp =
gpar(fill = key$col,
col = "transparent",
alpha = key$alpha)),
row = 3, col = 1)
}
if (open.lower > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(x = c(0, 1, 0.5),
y = c(1, 1, 0),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("lower.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[1],
col = "transparent",
alpha = key$alpha)),
row = 4, col = 1)
}
if (open.upper > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(x = c(0, 1, 0.5),
y = c(0, 0, 1),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("upper.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[length(key$col)],
col = "transparent",
alpha = key$alpha)),
row = 2, col = 1)
}
## borders
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 1), c(0, 0), c(0, 1), c(1, 1),
default.units = "npc",
name = trellis.grobname("border.sides", type="colorkey"),
gp = gp.border),
row = 3, col = 1)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 1), c(1, 1), c(0.5, 0.5), c(0, 0),
default.units = "npc",
name = trellis.grobname("border.lower", type="colorkey"),
gp = gp.border),
row = 4, col = 1)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 1), c(0, 0), c(0.5, 0.5), c(1, 1),
default.units = "npc",
name = trellis.grobname("border.upper", type="colorkey"),
gp = gp.border),
row = 2, col = 1)
## labels
if (do.labels)
{
if (key$tck != 0)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(x0 = rep(0, length(labscat)),
y0 = labscat,
x1 = rep(key$tck / (1 + key$tck), length(labscat)),
y1 = labscat,
vp = viewport(yscale = atrange),
default.units = "native",
name = trellis.grobname("ticks",
type="colorkey"),
gp =
gpar(col = axis.line$col,
lty = axis.line$lty,
lwd = axis.line$lwd)),
row = 3, col = 2)
key.gf <- placeGrob(key.gf,
labelsGrob,
row = 3, col = 3)
}
}
else if (key$space == "left")
{
labelsGrob <-
if (do.labels)
textGrob(label = labels,
x = rep(1, length(labscat)),
y = labscat,
vp = viewport(yscale = atrange),
default.units = "native",
check.overlap = check.overlap,
just = if (rot == 90) c("center", "bottom") else c("right", "center"),
rot = rot,
name = trellis.grobname("labels", type="colorkey"),
gp =
gpar(col = col,
cex = cex,
fontfamily = fontfamily,
fontface = chooseFace(fontface, font),
lineheight = lineheight))
else nullGrob()
heights.x <- c(0.5 * (1 - key$height),
key$height * c(open.upper, key.rect, open.lower),
0.5 * (1 - key$height))
heights.units <- rep("null", 5)
widths.x <- c(do.labels * 1, do.labels * (0.3 + key$tck * 0.3), 0.6 * key$width)
widths.units <- c("grobwidth", "lines", "lines")
widths.data <- list(labelsGrob, NULL, NULL)
key.layout <-
grid.layout(nrow = 5, ncol = 3,
heights = unit(heights.x, heights.units),
widths = unit(widths.x, widths.units, data = widths.data),
respect = TRUE)
key.gf <- frameGrob(layout = key.layout, vp = vp,
name = trellis.grobname("frame",
type="colorkey"))
if (key$raster)
{
key.gf <- placeGrob(key.gf,
rasterGrob(matrix(rev(key$col), ncol = 1),
width = 1, height = 1,
vp = viewport(clip = "on"),
name = trellis.grobname("raster",
type="colorkey"),
interpolate = key$interpolate),
row = 3, col = 3)
}
else
{
key.gf <- placeGrob(key.gf,
rectGrob(x = rep(.5, length(reccentre)),
y = reccentre,
default.units = "native",
vp = viewport(yscale = atrange),
height = recdim,
name = trellis.grobname("image",
type="colorkey"),
gp =
gpar(fill = key$col,
col = "transparent",
alpha = key$alpha)),
row = 3, col = 3)
}
if (open.lower > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(x = c(0, 1, 0.5),
y = c(1, 1, 0),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("lower.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[1],
col = "transparent",
alpha = key$alpha)),
row = 4, col = 3)
}
if (open.upper > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(x = c(0, 1, 0.5),
y = c(0, 0, 1),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("upper.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[length(key$col)],
col = "transparent",
alpha = key$alpha)),
row = 2, col = 3)
}
## borders
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 1), c(0, 0), c(0, 1), c(1, 1),
default.units = "npc",
name = trellis.grobname("border.sides", type="colorkey"),
gp = gp.border),
row = 3, col = 3)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 1), c(1, 1), c(0.5, 0.5), c(0, 0),
default.units = "npc",
name = trellis.grobname("border.lower", type="colorkey"),
gp = gp.border),
row = 4, col = 3)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 1), c(0, 0), c(0.5, 0.5), c(1, 1),
default.units = "npc",
name = trellis.grobname("border.upper", type="colorkey"),
gp = gp.border),
row = 2, col = 3)
## labels
if (do.labels)
{
if (key$tck != 0)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(x0 = rep(1, length(labscat)),
y0 = labscat,
x1 = rep(1 - key$tck / (1 + key$tck), length(labscat)),
y1 = labscat,
vp = viewport(yscale = atrange),
default.units = "native",
name = trellis.grobname("ticks",
type="colorkey"),
gp =
gpar(col = axis.line$col,
lty = axis.line$lty,
lwd = axis.line$lwd)),
row = 3, col = 2)
key.gf <- placeGrob(key.gf,
labelsGrob,
row = 3, col = 1)
}
}
else if (key$space == "top")
{
labelsGrob <-
if (do.labels)
textGrob(label = labels,
y = rep(0, length(labscat)),
x = labscat,
vp = viewport(xscale = atrange),
default.units = "native",
check.overlap = check.overlap,
just = if (rot == 0) c("center","bottom") else c("left", "center"),
rot = rot,
name = trellis.grobname("labels", type="colorkey"),
gp =
gpar(col = col,
cex = cex,
fontfamily = fontfamily,
fontface = chooseFace(fontface, font),
lineheight = lineheight))
else nullGrob()
widths.x <- c(0.5 * (1 - key$height),
key$height * c(open.lower, key.rect, open.upper),
0.5 * (1 - key$height))
widths.units <- rep("null", 5)
heights.x <- c(do.labels * 1, do.labels * (0.3 + key$tck * 0.3), 0.6 * key$width)
heights.units <- c("grobheight", "lines", "lines")
heights.data <- list(labelsGrob, NULL, NULL)
key.layout <-
grid.layout(nrow = 3, ncol = 5,
heights = unit(heights.x, heights.units, data = heights.data),
widths = unit(widths.x, widths.units),
respect = TRUE)
key.gf <- frameGrob(layout = key.layout, vp = vp,
name = trellis.grobname("frame",
type="colorkey"))
if (key$raster)
{
key.gf <- placeGrob(key.gf,
rasterGrob(matrix(key$col, nrow = 1),
width = 1, height = 1,
vp = viewport(clip = "on"),
name = trellis.grobname("raster",
type="colorkey"),
interpolate = key$interpolate),
row = 3, col = 3)
}
else
{
key.gf <- placeGrob(key.gf,
rectGrob(y = rep(.5, length(reccentre)),
x = reccentre,
default.units = "native",
vp = viewport(xscale = atrange),
width = recdim,
name = trellis.grobname("image",
type="colorkey"),
gp =
gpar(fill = key$col,
col = "transparent",
alpha = key$alpha)),
row = 3, col = 3)
}
if (open.lower > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(y = c(0, 1, 0.5),
x = c(1, 1, 0),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("lower.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[1],
col = "transparent",
alpha = key$alpha)),
row = 3, col = 2)
}
if (open.upper > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(y = c(0, 1, 0.5),
x = c(0, 0, 1),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("upper.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[length(key$col)],
col = "transparent",
alpha = key$alpha)),
row = 3, col = 4)
}
## borders
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 0), c(0, 1), c(1, 1), c(0, 1),
default.units = "npc",
name = trellis.grobname("border.sides", type="colorkey"),
gp = gp.border),
row = 3, col = 3)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(1, 1), c(0, 1), c(0, 0), c(0.5, 0.5),
default.units = "npc",
name = trellis.grobname("border.lower", type="colorkey"),
gp = gp.border),
row = 3, col = 2)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 0), c(0, 1), c(1, 1), c(0.5, 0.5),
default.units = "npc",
name = trellis.grobname("border.upper", type="colorkey"),
gp = gp.border),
row = 3, col = 4)
## labels
if (do.labels)
{
if (key$tck != 0)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(y0 = rep(0, length(labscat)),
x0 = labscat,
y1 = rep(key$tck / (1 + key$tck), length(labscat)),
x1 = labscat,
vp = viewport(xscale = atrange),
default.units = "native",
name = trellis.grobname("ticks",
type="colorkey"),
gp =
gpar(col = axis.line$col,
lty = axis.line$lty,
lwd = axis.line$lwd)),
row = 2, col = 3)
key.gf <- placeGrob(key.gf,
labelsGrob,
row = 1, col = 3)
}
}
else if (key$space == "bottom")
{
labelsGrob <-
if (do.labels)
textGrob(label = labels,
y = rep(1, length(labscat)),
x = labscat,
vp = viewport(xscale = atrange),
default.units = "native",
check.overlap = check.overlap,
just = if (rot == 0) c("center", "top") else c("right", "center"),
rot = rot,
name = trellis.grobname("labels", type="colorkey"),
gp =
gpar(col = col,
cex = cex,
fontfamily = fontfamily,
fontface = chooseFace(fontface, font),
lineheight = lineheight))
else nullGrob()
widths.x <- c(0.5 * (1 - key$height),
key$height * c(open.lower, key.rect, open.upper),
0.5 * (1 - key$height))
widths.units <- rep("null", 5)
heights.x <- c(0.6 * key$width, do.labels * (0.3 + key$tck * 0.3), do.labels * 1)
heights.units <- c("lines", "lines", "grobheight")
heights.data <- list(NULL, NULL, labelsGrob)
key.layout <-
grid.layout(nrow = 3, ncol = 5,
heights = unit(heights.x, heights.units, data = heights.data),
widths = unit(widths.x, widths.units),
respect = TRUE)
key.gf <- frameGrob(layout = key.layout, vp = vp,
name = trellis.grobname("frame",
type="colorkey"))
if (key$raster)
{
key.gf <- placeGrob(key.gf,
rasterGrob(matrix(key$col, nrow = 1),
width = 1, height = 1,
vp = viewport(clip = "on"),
name = trellis.grobname("raster",
type="colorkey"),
interpolate = key$interpolate),
row = 1, col = 3)
}
else
{
key.gf <- placeGrob(key.gf,
rectGrob(y = rep(.5, length(reccentre)),
x = reccentre,
default.units = "native",
vp = viewport(xscale = atrange),
width = recdim,
name = trellis.grobname("image",
type="colorkey"),
gp =
gpar(fill = key$col,
col = "transparent",
alpha = key$alpha)),
row = 1, col = 3)
}
if (open.lower > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(y = c(0, 1, 0.5),
x = c(1, 1, 0),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("lower.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[1],
col = "transparent",
alpha = key$alpha)),
row = 1, col = 2)
}
if (open.upper > 0)
{
key.gf <- placeGrob(key.gf,
polygonGrob(y = c(0, 1, 0.5),
x = c(0, 0, 1),
default.units = "npc",
## vp = viewport(yscale = atrange),
name = trellis.grobname("upper.arrow",
type="colorkey"),
gp =
gpar(fill = key$col[length(key$col)],
col = "transparent",
alpha = key$alpha)),
row = 1, col = 4)
}
## borders
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 0), c(0, 1), c(1, 1), c(0, 1),
default.units = "npc",
name = trellis.grobname("border.sides", type="colorkey"),
gp = gp.border),
row = 1, col = 3)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(1, 1), c(0, 1), c(0, 0), c(0.5, 0.5),
default.units = "npc",
name = trellis.grobname("border.lower", type="colorkey"),
gp = gp.border),
row = 1, col = 2)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(c(0, 0), c(0, 1), c(1, 1), c(0.5, 0.5),
default.units = "npc",
name = trellis.grobname("border.upper", type="colorkey"),
gp = gp.border),
row = 1, col = 4)
## labels
if (do.labels)
{
if (key$tck != 0)
key.gf <- placeGrob(frame = key.gf,
segmentsGrob(y0 = rep(1, length(labscat)),
x0 = labscat,
y1 = rep(1 - key$tck / (1 + key$tck), length(labscat)),
x1 = labscat,
vp = viewport(xscale = atrange),
default.units = "native",
name = trellis.grobname("ticks",
type="colorkey"),
gp =
gpar(col = axis.line$col,
lty = axis.line$lty,
lwd = axis.line$lwd)),
row = 2, col = 3)
key.gf <- placeGrob(key.gf,
labelsGrob,
row = 3, col = 3)
}
}
if (!is.null(key$title))
{
tside <- title.control$side
tpadding <- title.control$padding
if (getRversion() >= "4.0.1")
{
## This is nicer, but only works with grid >= 4.0.1.
## Eventually make unconditional if we depend on R >= 4.0.1
## padding unit is not customizable, but can be controlled
## by title$padding
upad <- unit(tpadding * 0.5, "char")
key.gf <-
switch(tside,
left = packGrob(packGrob(key.gf, nullGrob(), side = tside, width = upad),
title.grob, side = tside),
right = packGrob(packGrob(key.gf, nullGrob(), side = tside, width = upad),
title.grob, side = tside),
top = packGrob(packGrob(key.gf, nullGrob(), side = tside, height = upad),
title.grob, side = tside),
bottom = packGrob(packGrob(key.gf, nullGrob(), side = tside, height = upad),
title.grob, side = tside))
}
else
{
key.title.layout <-
switch(tside,
left = grid.layout(nrow = 1, ncol = 3,
heights = unit(1, "grobheight", list(key.gf)),
widths = unit(c(1, 0.5 * tpadding, 1), c("grobwidth", "char", "grobwidth"), list(title.grob, NULL, key.gf))),
right = grid.layout(nrow = 1, ncol = 3,
heights = unit(1, "grobheight", list(key.gf)),
widths = unit(c(1, 0.5 * tpadding, 1), c("grobwidth", "char", "grobwidth"), list(key.gf, NULL, title.grob))),
top = grid.layout(nrow = 3, ncol = 1,
heights = unit(c(1, 0.5 * tpadding, 1), c("grobheight", "char", "grobheight"), list(title.grob, NULL, key.gf)),
widths = unit(1, "grobwidth", list(key.gf))),
bottom = grid.layout(nrow = 3, ncol = 1,
heights = unit(c(1, 0.5 * tpadding, 1), c("grobheight", "char", "grobheight"), list(key.gf, NULL, title.grob)),
widths = unit(1, "grobwidth", list(key.gf))))
key.title.gf <- frameGrob(layout = key.title.layout, vp = vp,
name = trellis.grobname("titleframe",
type="colorkey"))
key.title.gf <-
switch(tside,
left = placeGrob(placeGrob(key.title.gf, key.gf, row = 1, col = 3), title.grob, row = 1, col = 1),
right = placeGrob(placeGrob(key.title.gf, key.gf, row = 1, col = 1), title.grob, row = 1, col = 3),
top = placeGrob(placeGrob(key.title.gf, key.gf, row = 3, col = 1), title.grob, row = 1, col = 1),
bottom = placeGrob(placeGrob(key.title.gf, key.gf, row = 1, col = 1), title.grob, row = 3, col = 1))
key.gf <- key.title.gf
}
}
if (draw)
grid.draw(key.gf)
key.gf
}
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.