[Rd] bug and proposed fix in print.trellis 1.7.0 (PR#2859)
rmh at surfer.sbm.temple.edu
rmh at surfer.sbm.temple.edu
Sun Apr 27 17:44:09 MEST 2003
sent again without attachments at Peter Dalgaard's request
description:
# Your mailer is set to "none" (default on Windows),
# hence we cannot send the bug report directly from R.
# Please copy the bug report (after finishing it) to
# your favorite email program and send it to
#
# r-bugs at r-project.org
#
######################################################
The new feature described in rw1070/library/lattice/Changes is very
useful and is needed for several of the examples I showed at DSC-2003.
> scales
> ------
> In anticipation of future use (in nlme, for example), the at and
> labels components of scales can now be a list. Each element
> corresponds to a panel. This is thoroughly untested and not guaranteed
> to work.
It currently rejects correctly formed user labels. I attach an
example of the problem and a proposed fix.
Rich
--please do not edit the information below--
Version:
platform = i386-pc-mingw32
arch = i386
os = mingw32
system = i386, mingw32
status =
major = 1
minor = 7.0
year = 2003
month = 04
day = 16
language = R
Windows XP Home Edition (build 2600) Service Pack 1.0
Search Path:
.GlobalEnv, file:c:/HOME/rmh/hh/splus.library/.RData, package:grid, package:lattice, package:methods, package:ctest, package:mva, package:modreg, package:nls, package:ts, Autoloads, package:base
example:
## print.trellis bug in R 1.7.0
tmp <- data.frame(a=factor(c("a","b","c")),
b=factor(c("d","e","f")),
d=factor(c(1,1,2)))
xyplot(a ~ b | d, data=tmp, ## works
scales=list(alternating=F))
xyplot(a ~ b | d, data=tmp, ## Invalid value for labels
scales=list(x=list(labels=list(c("d","e",""),c("","","f")),
alternating=F)))
source("print.trellis.r") ## rmh proposed fix
xyplot(a ~ b | d, data=tmp, ## now it works
scales=list(x=list(labels=list(c("d","e",""),c("","","f")),
alternating=F)))
proposed fix:
print.trellis <-
function (x, position, split, more = FALSE, newpage = TRUE, panel.height = list(1,
"null"), panel.width = list(1, "null"), ...)
{
if (is.null(dev.list()))
trellis.device()
else if (is.null(trellis.par.get()))
trellis.device(device = .Device, new = FALSE)
bg = trellis.par.get("background")$col
new <- TRUE
if (.lattice.print.more || !newpage)
new <- FALSE
.lattice.print.more <<- more
usual <- (missing(position) & missing(split))
fontsize.default <- trellis.par.get("fontsize")$default
if (!missing(position)) {
if (length(position) != 4)
stop("Incorrect value of position")
if (new) {
grid.newpage()
grid.rect(gp = gpar(fill = bg, col = "transparent"))
}
push.viewport(viewport(x = position[1], y = position[2],
width = position[3] - position[1], height = position[4] -
position[2], just = c("left", "bottom")))
if (!missing(split)) {
if (length(split) != 4)
stop("Incorrect value of split")
push.viewport(viewport(layout = grid.layout(nrow = split[4],
ncol = split[3])))
push.viewport(viewport(layout.pos.row = split[2],
layout.pos.col = split[1]))
}
}
else if (!missing(split)) {
if (length(split) != 4)
stop("Incorrect value of split")
if (new) {
grid.newpage()
grid.rect(gp = gpar(fill = bg, col = "transparent"))
}
push.viewport(viewport(layout = grid.layout(nrow = split[4],
ncol = split[3])))
push.viewport(viewport(layout.pos.row = split[2], layout.pos.col = split[1]))
}
panel <- if (is.function(x$panel))
x$panel
else if (is.character(x$panel))
get(x$panel)
else eval(x$panel)
x$strip <- if (is.function(x$strip))
x$strip
else if (is.character(x$strip))
get(x$strip)
else eval(x$strip)
axis.line <- trellis.par.get("axis.line")
number.of.cond <- length(x$condlevels)
layout.respect <- !x$aspect.fill
if (layout.respect)
panel.height[[1]] <- x$aspect.ratio * panel.width[[1]]
if (!is.null(x$key)) {
key.gf <- draw.key(x$key)
key.space <- if ("space" %in% names(x$key))
x$key$space
else if ("x" %in% names(x$key) || "corner" %in% names(x$key))
"inside"
else "top"
}
else if (!is.null(x$colorkey)) {
key.gf <- draw.colorkey(x$colorkey)
key.space <- if ("space" %in% names(x$colorkey))
x$colorkey$space
else "right"
}
xaxis.col <- if (is.logical(x$x.scales$col))
axis.line$col
else x$x.scales$col
xaxis.font <- if (is.logical(x$x.scales$font))
1
else x$x.scales$font
xaxis.cex <- x$x.scales$cex
xaxis.rot <- if (is.logical(x$x.scales$rot))
c(0, 0)
else x$x.scales$rot
yaxis.col <- if (is.logical(x$y.scales$col))
axis.line$col
else x$y.scales$col
yaxis.font <- if (is.logical(x$y.scales$font))
1
else x$y.scales$font
yaxis.cex <- x$y.scales$cex
yaxis.rot <- if (!is.logical(x$y.scales$rot))
x$y.scales$rot
else if (x$y.scales$relation != "same" && is.logical(x$y.scales$labels))
c(90, 90)
else c(0, 0)
strip.col.default.bg <- rep(trellis.par.get("strip.background")$col,
length = number.of.cond)
strip.col.default.fg <- rep(trellis.par.get("strip.shingle")$col,
length = number.of.cond)
cond.max.level <- integer(number.of.cond)
for (i in 1:number.of.cond) {
cond.max.level[i] <- length(x$condlevels[[i]])
}
if (x$layout[1] == 0) {
ddim <- par("din")
device.aspect <- ddim[2]/ddim[1]
panel.aspect <- panel.height[[1]]/panel.width[[1]]
plots.per.page <- x$layout[2]
m <- max(1, round(sqrt(x$layout[2] * device.aspect/panel.aspect)))
n <- ceiling(plots.per.page/m)
m <- ceiling(plots.per.page/n)
x$layout[1] <- n
x$layout[2] <- m
}
else plots.per.page <- x$layout[1] * x$layout[2]
cols.per.page <- x$layout[1]
rows.per.page <- x$layout[2]
number.of.pages <- x$layout[3]
if (cols.per.page > 1)
x.between <- rep(x$x.between, length = cols.per.page -
1)
if (rows.per.page > 1)
y.between <- rep(x$y.between, length = rows.per.page -
1)
x.alternating <- rep(x$x.scales$alternating, length = cols.per.page)
y.alternating <- rep(x$y.scales$alternating, length = rows.per.page)
x.relation.same <- x$x.scales$relation == "same"
y.relation.same <- x$y.scales$relation == "same"
xlog <- x$x.scales$log
ylog <- x$y.scales$log
if (is.logical(xlog) && xlog)
xlog <- 10
if (is.logical(ylog) && ylog)
ylog <- 10
have.xlog <- !is.logical(xlog) || xlog
have.ylog <- !is.logical(ylog) || ylog
xlogbase <- if (is.numeric(xlog))
xlog
else exp(1)
ylogbase <- if (is.numeric(ylog))
ylog
else exp(1)
xlogpaste <- if (have.xlog)
paste(as.character(xlog), "^", sep = "")
else ""
ylogpaste <- if (have.ylog)
paste(as.character(ylog), "^", sep = "")
else ""
have.main <- !(is.null(x$main$label) || (is.character(x$main$label) &&
x$main$label == ""))
have.sub <- !(is.null(x$sub$label) || (is.character(x$sub$label) &&
x$sub$label == ""))
have.xlab <- !(is.null(x$xlab$label) || (is.character(x$xlab$label) &&
x$xlab$label == ""))
have.ylab <- !(is.null(x$ylab$label) || (is.character(x$ylab$label) &&
x$ylab$label == ""))
n.row <- rows.per.page * (number.of.cond + 3) + (rows.per.page -
1) + 11
n.col <- 3 * cols.per.page + (cols.per.page - 1) + 9
if (layout.respect) {
layout.respect <- matrix(0, n.row, n.col)
layout.respect[number.of.cond + 6 + (1:rows.per.page -
1) * (number.of.cond + 4), (1:cols.per.page - 1) *
4 + 8] <- 1
}
heights.x <- rep(1, n.row)
heights.units <- rep("lines", n.row)
heights.data <- as.list(1:n.row)
widths.x <- rep(1, n.col)
widths.units <- rep("lines", n.col)
widths.data <- as.list(1:n.col)
heights.x[number.of.cond + 6 + (1:rows.per.page - 1) * (number.of.cond +
4)] <- panel.height[[1]]
heights.units[number.of.cond + 6 + (1:rows.per.page - 1) *
(number.of.cond + 4)] <- panel.height[[2]]
heights.x[number.of.cond + 7 + (1:rows.per.page - 1) * (number.of.cond +
4)] <- 0
heights.x[number.of.cond + 8 + (1:rows.per.page - 1) * (number.of.cond +
4)] <- 0
heights.x[4] <- 0
heights.x[5] <- 0
heights.x[n.row - 4] <- 0
heights.x[n.row - 5] <- 0
if (rows.per.page > 1)
heights.x[number.of.cond + 9 + ((if (x$as.table)
1:(rows.per.page - 1)
else (rows.per.page - 1):1) - 1) * (number.of.cond +
4)] <- y.between
heights.x[1] <- 0.5
heights.x[2] <- if (have.main)
2 * x$main$cex
else 0
if (have.main) {
heights.units[2] <- "strheight"
heights.data[[2]] <- x$main$lab
}
heights.x[n.row] <- 0.5
heights.x[n.row - 1] <- if (have.sub)
2 * x$sub$cex
else 0
if (have.sub) {
heights.units[n.row - 1] <- "strheight"
heights.data[[n.row - 1]] <- x$sub$lab
}
heights.x[3] <- 0
heights.x[n.row - 2] <- 0
heights.insertlist.position <- 0
heights.insertlist.unit <- unit(1, "null")
if (x$x.scales$draw) {
if (x.relation.same) {
lab <- calculateAxisComponents(x = x$x.limits, at = x$x.scales$at,
labels = x$x.scales$lab, have.log = have.xlog,
logbase = xlogbase, logpaste = xlogpaste, abbreviate = x$x.scales$abbr,
minlength = x$x.scales$minl, n = x$x.scales$tick.number)$lab
## if (is.character(lab))
if (all(sapply(lab, is.character))) ## rmh
strbar <- as.list(lab)
else if (is.expression(lab)) {
strbar <- list()
for (ss in seq(along = lab)) strbar <- c(strbar,
list(lab[ss]))
}
else stop("Invalid value for labels")
heights.x[5] <- 0.5 + max(0.001, x$x.scales$tck[2]) *
0.3
heights.x[n.row - 5] <- 0.5 + max(0.001, x$x.scales$tck[1]) *
0.3
if (any(x.alternating == 2 | x.alternating == 3)) {
if (xaxis.rot[2] %in% c(0, 180)) {
heights.insertlist.position <- c(heights.insertlist.position,
4)
heights.insertlist.unit <- unit.c(heights.insertlist.unit,
max(unit(rep(1 * xaxis.cex[2], length(strbar)),
"strheight", strbar)))
}
else {
heights.insertlist.position <- c(heights.insertlist.position,
4)
heights.insertlist.unit <- unit.c(heights.insertlist.unit,
max(unit(rep(1 * xaxis.cex[2] * abs(sin(xaxis.rot[2] *
base::pi/180)), length(strbar)), "strwidth",
strbar)))
}
}
if (any(x.alternating == 1 | x.alternating == 3)) {
if (xaxis.rot[1] %in% c(0, 180)) {
heights.insertlist.position <- c(heights.insertlist.position,
n.row - 4)
heights.insertlist.unit <- unit.c(heights.insertlist.unit,
max(unit(rep(1 * xaxis.cex[1], length(strbar)),
"strheight", strbar)))
}
else {
heights.insertlist.position <- c(heights.insertlist.position,
n.row - 4)
heights.insertlist.unit <- unit.c(heights.insertlist.unit,
max(unit(rep(1 * xaxis.cex[1] * abs(sin(xaxis.rot[1] *
base::pi/180)), length(strbar)), "strwidth",
strbar)))
}
}
}
else {
labelChars <- character(0)
labelExprs <- expression(0)
for (i in seq(along = x$x.limits)) {
lab <- calculateAxisComponents(x = x$x.limits[[i]],
at = if (is.list(x$x.scales$at))
x$x.scales$at[[i]]
else x$x.scales$at, labels = if (is.list(x$x.scales$lab))
x$x.scales$lab[[i]]
else x$x.scales$lab, have.log = have.xlog,
logbase = xlogbase, logpaste = xlogpaste, abbreviate = x$x.scales$abbr,
minlength = x$x.scales$minl, n = x$x.scales$tick.number)$lab
if (is.character(lab))
labelChars <- c(labelChars, lab)
else if (is.expression(lab))
labelExprs <- c(labelExprs, lab)
}
labelChars <- unique(labelChars)
strbar <- list()
for (ss in labelChars) strbar <- c(strbar, list(ss))
for (ss in seq(along = labelExprs)) strbar <- c(strbar,
list(labelExprs[ss]))
if (xaxis.rot[1] %in% c(0, 180)) {
heights.x[number.of.cond + 7 + (1:rows.per.page -
1) * (number.of.cond + 4)] <- max(0.001, x$x.scales$tck[1]) *
0.3
heights.insertlist.position <- c(heights.insertlist.position,
number.of.cond + 8 + (1:rows.per.page - 1) *
(number.of.cond + 4))
for (i in 1:rows.per.page) heights.insertlist.unit <- unit.c(heights.insertlist.unit,
max(unit(rep(1.5 * xaxis.cex[1], length(strbar)),
"strheight", strbar)))
}
else {
heights.x[number.of.cond + 7 + (1:rows.per.page -
1) * (number.of.cond + 4)] <- max(0.001, x$x.scales$tck[1]) *
0.3
heights.insertlist.position <- c(heights.insertlist.position,
number.of.cond + 8 + (1:rows.per.page - 1) *
(number.of.cond + 4))
for (i in 1:rows.per.page) heights.insertlist.unit <- unit.c(heights.insertlist.unit,
max(unit(rep(1.5 * xaxis.cex[1] * abs(sin(xaxis.rot[1] *
base::pi/180)), length(strbar)), "strwidth",
strbar)))
}
}
}
heights.x[n.row - 3] <- if (have.xlab)
2 * x$xlab$cex
else 0
if (have.xlab) {
heights.units[n.row - 3] <- "strheight"
heights.data[[n.row - 3]] <- x$xlab$lab
}
for (crr in 1:number.of.cond) heights.x[number.of.cond +
6 + (1:rows.per.page - 1) * (number.of.cond + 4) - crr] <- if (is.logical(x$strip))
0
else 1.1 * x$par.strip.text$cex * x$par.strip.text$lines
widths.x[3] <- if (have.ylab)
2 * x$ylab$cex
else 0
if (have.ylab) {
widths.units[3] <- "strheight"
widths.data[[3]] <- x$ylab$lab
}
widths.x[(1:cols.per.page - 1) * 4 + 8] <- panel.width[[1]]
widths.units[(1:cols.per.page - 1) * 4 + 8] <- panel.width[[2]]
widths.x[(1:cols.per.page - 1) * 4 + 7] <- 0
widths.x[(1:cols.per.page - 1) * 4 + 6] <- 0
widths.x[4] <- 0
widths.x[5] <- 0
widths.x[n.col - 2] <- 0
widths.x[n.col - 3] <- 0
if (cols.per.page > 1)
widths.x[(1:(cols.per.page - 1) - 1) * 4 + 9] <- x.between
widths.x[1] <- 0.5
widths.x[n.col] <- 0.5
widths.x[2] <- 0
widths.x[n.col - 1] <- 0
widths.insertlist.position <- 0
widths.insertlist.unit <- unit(1, "null")
if (x$y.scales$draw) {
if (y.relation.same) {
lab <- calculateAxisComponents(x = x$y.limits, at = x$y.scales$at,
labels = x$y.scales$lab, have.log = have.ylog,
logbase = ylogbase, logpaste = ylogpaste, abbreviate = x$y.scales$abbr,
minlength = x$y.scales$minl, n = x$y.scales$tick.number)$lab
## if (is.character(lab))
if (all(sapply(lab, is.character))) ## rmh
strbar <- as.list(lab)
else if (is.expression(lab)) {
strbar <- list()
for (ss in seq(along = lab)) strbar <- c(strbar,
list(lab[ss]))
}
else stop("Invalid value for labels")
widths.x[5] <- 0.5 + max(0.001, x$y.scales$tck[1]) *
0.3
widths.x[n.col - 3] <- max(1, x$y.scales$tck[2]) *
0.5
if (any(y.alternating == 1 | y.alternating == 3)) {
if (abs(yaxis.rot[1]) == 90) {
widths.insertlist.position <- c(widths.insertlist.position,
4)
widths.insertlist.unit <- unit.c(widths.insertlist.unit,
max(unit(1 * rep(yaxis.cex[1], length(strbar)),
"strheight", data = strbar)))
}
else {
widths.insertlist.position <- c(widths.insertlist.position,
4)
widths.insertlist.unit <- unit.c(widths.insertlist.unit,
max(unit(rep(1 * yaxis.cex[1] * abs(cos(yaxis.rot[1] *
base::pi/180)), length(strbar)), "strwidth",
strbar)))
}
}
if (any(y.alternating == 2 | y.alternating == 3)) {
if (abs(yaxis.rot[2]) == 90) {
widths.insertlist.position <- c(widths.insertlist.position,
n.col - 2)
widths.insertlist.unit <- unit.c(widths.insertlist.unit,
max(unit(rep(1 * yaxis.cex[2], length(strbar)),
"strheight", strbar)))
}
else {
widths.insertlist.position <- c(widths.insertlist.position,
n.col - 2)
widths.insertlist.unit <- unit.c(widths.insertlist.unit,
max(unit(rep(1 * yaxis.cex[2] * abs(cos(yaxis.rot[2] *
base::pi/180)), length(strbar)), "strwidth",
strbar)))
}
}
}
else {
labelChars <- character(0)
labelExprs <- expression(0)
for (i in seq(along = x$y.limits)) {
lab <- calculateAxisComponents(x = x$y.limits[[i]],
at = if (is.list(x$y.scales$at))
x$y.scales$at[[i]]
else x$y.scales$at, labels = if (is.list(x$y.scales$lab))
x$y.scales$lab[[i]]
else x$y.scales$lab, have.log = have.ylog,
logbase = ylogbase, logpaste = ylogpaste, abbreviate = x$y.scales$abbr,
minlength = x$y.scales$minl, n = x$y.scales$tick.number)$lab
if (is.character(lab))
labelChars <- c(labelChars, lab)
else if (is.expression(lab))
labelExprs <- c(labelExprs, lab)
}
labelChars <- unique(labelChars)
strbar <- list()
for (ss in labelChars) strbar <- c(strbar, list(ss))
for (ss in seq(along = labelExprs)) strbar <- c(strbar,
list(labelExprs[ss]))
if (abs(yaxis.rot[1]) == 90) {
widths.x[(1:cols.per.page - 1) * 4 + 7] <- max(0.001,
x$y.scales$tck[1]) * 0.3
widths.insertlist.position <- c(widths.insertlist.position,
(1:cols.per.page - 1) * 4 + 6)
for (i in 1:cols.per.page) widths.insertlist.unit <- unit.c(widths.insertlist.unit,
max(unit(rep(1.5 * yaxis.cex[1], length(strbar)),
"strheight", strbar)))
}
else {
widths.x[(1:cols.per.page - 1) * 4 + 7] <- max(0.001,
x$y.scales$tck[1]) * 0.3
widths.insertlist.position <- c(widths.insertlist.position,
(1:cols.per.page - 1) * 4 + 6)
for (i in 1:cols.per.page) widths.insertlist.unit <- unit.c(widths.insertlist.unit,
max(unit(rep(1.2 * yaxis.cex[1] * abs(cos(yaxis.rot[1] *
base::pi/180)), length(strbar)), "strwidth",
strbar)))
}
}
}
if (!is.null(x$key) || !is.null(x$colorkey)) {
if (key.space == "left") {
widths.x[2] <- 1.2
widths.units[2] <- "grobwidth"
widths.data[[2]] <- key.gf
}
else if (key.space == "right") {
widths.x[n.col - 1] <- 1.2
widths.units[n.col - 1] <- "grobwidth"
widths.data[[n.col - 1]] <- key.gf
}
else if (key.space == "top") {
heights.x[3] <- 1.2
heights.units[3] <- "grobheight"
heights.data[[3]] <- key.gf
}
else if (key.space == "bottom") {
heights.x[n.row - 2] <- 1.2
heights.units[n.row - 2] <- "grobheight"
heights.data[[n.row - 2]] <- key.gf
}
}
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])
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])
page.layout <- grid.layout(nrow = n.row, ncol = n.col, widths = layout.widths,
heights = layout.heights, respect = layout.respect)
cond.current.level <- rep(1, number.of.cond)
panel.number <- 1
for (page.number in 1:number.of.pages) if (!any(cond.max.level -
cond.current.level < 0)) {
if (usual) {
if (new)
grid.newpage()
grid.rect(gp = gpar(fill = bg, col = "transparent"))
new <- TRUE
}
push.viewport(viewport(layout = page.layout, gp = gpar(fontsize = fontsize.default,
col = axis.line$col, lty = axis.line$lty, lwd = axis.line$lwd)))
if (have.main)
grid.text(label = x$main$label, gp = gpar(col = x$main$col,
font = x$main$font, fontsize = fontsize.default *
x$main$cex), vp = viewport(layout.pos.row = 2))
if (have.sub)
grid.text(label = x$sub$label, gp = gpar(col = x$sub$col,
font = x$sub$font, fontsize = fontsize.default *
x$sub$cex), vp = viewport(layout.pos.row = n.row -
1))
if (have.xlab)
grid.text(label = x$xlab$label, gp = gpar(col = x$xlab$col,
font = x$xlab$font, fontsize = fontsize.default *
x$xlab$cex), vp = viewport(layout.pos.row = n.row -
3, layout.pos.col = c(6, n.col - 4)))
if (have.ylab)
grid.text(label = x$ylab$label, rot = 90, gp = gpar(col = x$ylab$col,
font = x$ylab$font, fontsize = fontsize.default *
x$ylab$cex), vp = viewport(layout.pos.col = 3,
layout.pos.row = c(6, n.row - 6)))
for (row in 1:rows.per.page) for (column in 1:cols.per.page) if (!any(cond.max.level -
cond.current.level < 0) && (row - 1) * cols.per.page +
column <= plots.per.page) {
if (!is.list(x$panel.args[[panel.number]]))
panel.number <- panel.number + 1
else {
actual.row <- if (x$as.table)
(rows.per.page - row + 1)
else row
pos.row <- 6 + number.of.cond + (rows.per.page -
actual.row) * (number.of.cond + 4)
pos.col <- (column - 1) * 4 + 8
xlabelinfo <- calculateAxisComponents(x = if (x.relation.same)
x$x.limits
else x$x.limits[[panel.number]], at = if (is.list(x$x.scales$at))
x$x.scales$at[[panel.number]]
else x$x.scales$at, labels = if (is.list(x$x.scales$lab))
x$x.scales$lab[[panel.number]]
else x$x.scales$lab, have.log = have.xlog, logbase = xlogbase,
logpaste = xlogpaste, abbreviate = x$x.scales$abbr,
minlength = x$x.scales$minl, n = x$x.scales$tick.number)
ylabelinfo <- calculateAxisComponents(x = if (y.relation.same)
x$y.limits
else x$y.limits[[panel.number]], at = if (is.list(x$y.scales$at))
x$y.scales$at[[panel.number]]
else x$y.scales$at, labels = if (is.list(x$y.scales$lab))
x$y.scales$lab[[panel.number]]
else x$y.scales$lab, have.log = have.ylog, logbase = ylogbase,
logpaste = ylogpaste, abbreviate = x$y.scales$abbr,
minlength = x$y.scales$minl, n = x$y.scales$tick.number)
xscale <- xlabelinfo$num.limit
yscale <- ylabelinfo$num.limit
push.viewport(viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col, xscale = xscale,
yscale = yscale, clip = TRUE, gp = gpar(fontsize = fontsize.default)))
pargs <- c(x$panel.args[[panel.number]], x$panel.args.common,
list(panel.number = panel.number))
if (!("..." %in% names(formals(panel))))
pargs <- pargs[names(formals(panel))]
do.call("panel", pargs)
grid.rect()
pop.viewport()
if (!x.relation.same && x$x.scales$draw) {
axs <- x$x.scales
ok <- (xlabelinfo$at >= xscale[1] & xlabelinfo$at <=
xscale[2])
push.viewport(viewport(layout.pos.row = pos.row +
1, layout.pos.col = pos.col, xscale = xscale))
if (axs$tck[1] != 0 && any(ok))
grid.segments(y0 = unit(rep(1, sum(ok)),
"npc"), y1 = unit(rep(1, sum(ok)), "npc") -
unit(rep(0.3 * axs$tck[1], sum(ok)), "lines"),
x0 = unit(xlabelinfo$at[ok], "native"),
x1 = unit(xlabelinfo$at[ok], "native"),
gp = gpar(col = xaxis.col))
pop.viewport()
if (any(ok))
grid.text(label = xlabelinfo$label[ok], x = unit(xlabelinfo$at[ok],
"native"), y = unit(if (xaxis.rot[1] %in%
c(0, 180))
0.5
else 0.95, "npc"), just = if (xaxis.rot[1] ==
0)
c("centre", "centre")
else if (xaxis.rot[1] == 180)
c("centre", "centre")
else if (xaxis.rot[1] > 0)
c("right", "centre")
else c("left", "centre"), rot = xaxis.rot[1],
check.overlap = xlabelinfo$check.overlap,
gp = gpar(col = xaxis.col, font = xaxis.font,
fontsize = axs$cex[1] * fontsize.default),
vp = viewport(layout.pos.row = pos.row +
2, layout.pos.col = pos.col, xscale = xscale))
}
if (!y.relation.same && x$y.scales$draw) {
axs <- x$y.scales
ok <- (ylabelinfo$at >= yscale[1] & ylabelinfo$at <=
yscale[2])
push.viewport(viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col - 1, yscale = yscale))
if (axs$tck[1] != 0 && any(ok))
grid.segments(x0 = unit(rep(1, sum(ok)),
"npc"), x1 = unit(rep(1, sum(ok)), "npc") -
unit(rep(0.3 * axs$tck[1], sum(ok)), "lines"),
y0 = unit(ylabelinfo$at[ok], "native"),
y1 = unit(ylabelinfo$at[ok], "native"),
gp = gpar(col = yaxis.col))
pop.viewport()
if (any(ok))
grid.text(label = ylabelinfo$label[ok], y = unit(ylabelinfo$at[ok],
"native"), x = unit(if (abs(yaxis.rot[1]) ==
90)
0.5
else 0.95, "npc"), just = if (yaxis.rot[1] ==
90)
c("centre", "centre")
else if (yaxis.rot[1] == -90)
c("centre", "centre")
else if (yaxis.rot[1] > -90 && yaxis.rot[1] <
90)
c("right", "centre")
else c("left", "centre"), rot = yaxis.rot[1],
check.overlap = ylabelinfo$check.overlap,
gp = gpar(col = yaxis.col, font = xaxis.font,
fontsize = axs$cex[1] * fontsize.default),
vp = viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col - 2, yscale = yscale))
}
if (y.relation.same && x$y.scales$draw) {
if (column == 1) {
axs <- x$y.scales
ok <- (ylabelinfo$at >= yscale[1] & ylabelinfo$at <=
yscale[2])
push.viewport(viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col - 3, yscale = yscale))
if (axs$tck[1] != 0 && any(ok))
grid.segments(x0 = unit(rep(1, sum(ok)),
"npc"), x1 = unit(rep(1, sum(ok)), "npc") -
unit(rep(0.3 * axs$tck[1], sum(ok)),
"lines"), y0 = unit(ylabelinfo$at[ok],
"native"), y1 = unit(ylabelinfo$at[ok],
"native"), gp = gpar(col = yaxis.col))
pop.viewport()
if (y.alternating[actual.row] == 1 || y.alternating[actual.row] ==
3)
if (any(ok))
grid.text(label = ylabelinfo$lab[ok],
y = unit(ylabelinfo$at[ok], "native"),
x = unit(if (abs(yaxis.rot[1]) == 90)
0.5
else 1, "npc"), just = if (yaxis.rot[1] ==
-90)
c("centre", "centre")
else if (yaxis.rot[1] == 90)
c("centre", "centre")
else if (yaxis.rot[1] > -90 && yaxis.rot[1] <
90)
c("right", "centre")
else c("left", "centre"), rot = yaxis.rot[1],
check.overlap = ylabelinfo$check.overlap,
gp = gpar(col = yaxis.col, font = yaxis.font,
fontsize = axs$cex[1] * fontsize.default),
vp = viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col - 4, yscale = yscale))
}
if (column == cols.per.page) {
axs <- x$y.scales
ok <- (ylabelinfo$at >= yscale[1] & ylabelinfo$at <=
yscale[2])
push.viewport(viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col + 1, yscale = yscale))
if (axs$tck[2] != 0 && any(ok))
grid.segments(x0 = unit(rep(0, sum(ok)),
"npc"), x1 = unit(rep(0.3 * axs$tck[2],
sum(ok)), "lines"), y0 = unit(ylabelinfo$at[ok],
"native"), y1 = unit(ylabelinfo$at[ok],
"native"), gp = gpar(col = yaxis.col))
pop.viewport()
if (y.alternating[actual.row] == 2 || y.alternating[actual.row] ==
3)
if (any(ok))
grid.text(label = ylabelinfo$label[ok],
y = unit(ylabelinfo$at[ok], "native"),
x = unit(if (abs(yaxis.rot[2]) == 90)
0.5
else 0, "npc"), just = if (yaxis.rot[2] ==
-90)
c("centre", "centre")
else if (yaxis.rot[2] == 90)
c("centre", "centre")
else if (yaxis.rot[2] > -90 && yaxis.rot[2] <
90)
c("left", "centre")
else c("right", "centre"), rot = yaxis.rot[2],
check.overlap = ylabelinfo$check.overlap,
gp = gpar(col = yaxis.col, font = yaxis.font,
fontsize = axs$cex[2] * fontsize.default),
vp = viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col + 2, yscale = yscale))
}
}
if (x.relation.same && x$x.scales$draw) {
if (actual.row == 1) {
axs <- x$x.scales
ok <- (xlabelinfo$at >= xscale[1] & xlabelinfo$at <=
xscale[2])
push.viewport(viewport(layout.pos.row = pos.row +
3, layout.pos.col = pos.col, xscale = xscale))
if (axs$tck[1] != 0 && any(ok))
grid.segments(y0 = unit(rep(1, sum(ok)),
"npc"), y1 = unit(rep(1, sum(ok)), "npc") -
unit(rep(0.3 * axs$tck[1], sum(ok)),
"lines"), x0 = unit(xlabelinfo$at[ok],
"native"), x1 = unit(xlabelinfo$at[ok],
"native"), gp = gpar(col = xaxis.col))
pop.viewport()
if (x.alternating[column] == 1 || x.alternating[column] ==
3)
if (any(ok)) {
grid.text(label = xlabelinfo$lab[ok],
x = unit(xlabelinfo$at[ok], "native"),
y = unit(if (xaxis.rot[1] %in% c(0,
180))
0.5
else 1, "npc"), just = if (xaxis.rot[1] ==
0)
c("centre", "centre")
else if (xaxis.rot[1] == 180)
c("centre", "centre")
else if (xaxis.rot[1] > 0)
c("right", "centre")
else c("left", "centre"), rot = xaxis.rot[1],
check.overlap = xlabelinfo$check.overlap,
gp = gpar(col = xaxis.col, font = xaxis.font,
fontsize = axs$cex[1] * fontsize.default),
vp = viewport(layout.pos.row = pos.row +
4, layout.pos.col = pos.col, xscale = xscale))
}
}
}
if (!is.logical(x$strip))
for (i in 1:number.of.cond) {
push.viewport(viewport(layout.pos.row = pos.row -
i, layout.pos.col = pos.col, clip = TRUE,
gp = gpar(fontsize = fontsize.default)))
grid.rect()
x$strip(which.given = i, which.panel = cond.current.level,
var.name = names(x$cond), factor.levels = if (!is.list(x$cond[[i]]))
x$cond[[i]]
else NULL, shingle.intervals = if (is.list(x$cond[[i]]))
do.call("rbind", x$cond[[i]])
else NULL, bg = strip.col.default.bg[i],
fg = strip.col.default.fg[i], par.strip.text = x$par.strip.text)
pop.viewport()
}
if (x.relation.same && x$x.scales$draw)
if (actual.row == rows.per.page) {
axs <- x$x.scales
ok <- (xlabelinfo$at >= xscale[1] & xlabelinfo$at <=
xscale[2])
push.viewport(viewport(layout.pos.row = pos.row -
1 - number.of.cond, layout.pos.col = pos.col,
xscale = xscale))
if (axs$tck[2] != 0 && any(ok))
grid.segments(y0 = unit(rep(0, sum(ok)),
"npc"), y1 = unit(rep(0.3 * axs$tck[2],
sum(ok)), "lines"), x0 = unit(xlabelinfo$at[ok],
"native"), x1 = unit(xlabelinfo$at[ok],
"native"), gp = gpar(col = xaxis.col))
pop.viewport()
if (x.alternating[column] == 2 || x.alternating[column] ==
3)
if (any(ok))
grid.text(label = xlabelinfo$label[ok],
x = unit(xlabelinfo$at[ok], "native"),
y = unit(if (xaxis.rot[2] %in% c(0,
180))
0.5
else 0, "npc"), just = if (xaxis.rot[2] ==
0)
c("centre", "centre")
else if (xaxis.rot[2] == 180)
c("centre", "centre")
else if (xaxis.rot[2] > 0)
c("left", "centre")
else c("right", "centre"), rot = xaxis.rot[2],
check.overlap = xlabelinfo$check.overlap,
gp = gpar(col = xaxis.col, font = xaxis.font,
fontsize = axs$cex[2] * fontsize.default),
vp = viewport(layout.pos.row = pos.row -
2 - number.of.cond, layout.pos.col = pos.col,
xscale = xscale))
}
cond.current.level <- cupdate(cond.current.level,
cond.max.level)
panel.number <- panel.number + 1
}
}
if (!is.null(x$key) || !is.null(x$colorkey)) {
if (key.space == "left") {
push.viewport(viewport(layout.pos.col = 2, layout.pos.row = c(6,
n.row - 6)))
grid.draw(key.gf)
pop.viewport()
}
else if (key.space == "right") {
push.viewport(viewport(layout.pos.col = n.col -
1, layout.pos.row = c(6, n.row - 6)))
grid.draw(key.gf)
pop.viewport()
}
else if (key.space == "top") {
push.viewport(viewport(layout.pos.row = 3, layout.pos.col = c(6,
n.col - 4)))
grid.draw(key.gf)
pop.viewport()
}
else if (key.space == "bottom") {
push.viewport(viewport(layout.pos.row = n.row -
2, layout.pos.col = c(6, n.col - 4)))
grid.draw(key.gf)
pop.viewport()
}
else if (key.space == "inside") {
push.viewport(viewport(layout.pos.row = c(1,
n.row), layout.pos.col = c(1, n.col)))
if (is.null(x$key$corner))
x$key$corner <- c(0, 1)
if (is.null(x$key$x))
x$key$x <- x$key$corner[1]
if (is.null(x$key$y))
x$key$y <- x$key$corner[2]
if (all(x$key$corner == c(0, 1))) {
push.viewport(viewport(layout = grid.layout(nrow = 3,
ncol = 3, widths = unit(c(x$key$x, 1, 1),
c("npc", "grobwidth", "null"), list(1,
key.gf, 1)), heights = unit(c(1 - x$key$y,
1, 1), c("npc", "grobheight", "null"),
list(1, key.gf, 1)))))
push.viewport(viewport(layout.pos.row = 2,
layout.pos.col = 2))
grid.draw(key.gf)
pop.viewport()
pop.viewport()
}
if (all(x$key$corner == c(1, 1))) {
push.viewport(viewport(layout = grid.layout(nrow = 3,
ncol = 3, heights = unit(c(1 - x$key$y, 1,
1), c("npc", "grobheight", "null"), list(1,
key.gf, 1)), widths = unit(c(1, 1, 1 -
x$key$x), c("null", "grobwidth", "npc"),
list(1, key.gf, 1)))))
push.viewport(viewport(layout.pos.row = 2,
layout.pos.col = 2))
grid.draw(key.gf)
pop.viewport()
pop.viewport()
}
if (all(x$key$corner == c(0, 0))) {
push.viewport(viewport(layout = grid.layout(nrow = 3,
ncol = 3, widths = unit(c(x$key$x, 1, 1),
c("npc", "grobwidth", "null"), list(1,
key.gf, 1)), heights = unit(c(1, 1, x$key$y),
c("null", "grobheight", "npc"), list(1,
key.gf, 1)))))
push.viewport(viewport(layout.pos.row = 2,
layout.pos.col = 2))
grid.draw(key.gf)
pop.viewport()
pop.viewport()
}
if (all(x$key$corner == c(1, 0))) {
push.viewport(viewport(layout = grid.layout(nrow = 3,
ncol = 3, widths = unit(c(1, 1, 1 - x$key$x),
c("null", "grobwidth", "npc"), list(1,
key.gf, 1)), heights = unit(c(1, 1, x$key$y),
c("null", "grobheight", "npc"), list(1,
key.gf, 1)))))
push.viewport(viewport(layout.pos.row = 2,
layout.pos.col = 2))
grid.draw(key.gf)
pop.viewport()
pop.viewport()
}
pop.viewport()
}
}
push.viewport(viewport(layout.pos.row = c(1, n.row),
layout.pos.col = c(1, n.col)))
if (!is.null(x$page))
x$page(page.number)
pop.viewport()
pop.viewport()
}
if (!missing(position)) {
if (!missing(split)) {
pop.viewport()
pop.viewport()
}
pop.viewport()
}
else if (!missing(split)) {
pop.viewport()
pop.viewport()
}
invisible(page.layout)
}
More information about the R-devel
mailing list