Nothing
R/trellisPlot.R
In QUALIFIER: Quality Control of Gated Flow Cytometry Experiments
Defines functions
stripEx
plot.trellisEx
# this plot function is from lattice package,we just adjust the order
# of plotting,plot the box of panel first in order to prevent the actual plot
#region from being covered by the box,such as some svg annotations
# Author: mike
###############################################################################
##reverse the order of strip plotting for conditional vairables
#' @import grid
stripEx <-
function(which.given,
which.panel,
## packet.number,
## panel.number,
var.name,
factor.levels,
shingle.intervals = NULL,
strip.names = c(FALSE, TRUE),
strip.levels = c(TRUE, FALSE),
sep = " : ",
style = 1,
horizontal = TRUE,
## FIXME: not sure how to incorporate alpha in strip colors
bg = trellis.par.get("strip.background")$col[which.given],
fg = trellis.par.get("strip.shingle")$col[which.given],
par.strip.text = trellis.par.get("add.text"))
{
# browser()
if (horizontal)
pushViewport(viewport(y = (length(which.panel)-which.given+1-0.5)/length(which.panel),
height = 1/length(which.panel),
clip = trellis.par.get("clip")$strip,
name = paste("strip.default", length(which.panel)-which.given+1, sep = ".")))
# pushViewport(viewport(y = (which.given-0.5)/length(which.panel),
# height = 1/length(which.panel),
# clip = trellis.par.get("clip")$strip,
# name = paste("strip.default", which.given, sep = ".")))
else
pushViewport(viewport(x = 1 - (length(which.panel)-which.given+1-0.5)/length(which.panel),
width = 1/length(which.panel),
clip = trellis.par.get("clip")$strip,
name = paste("strip.left.default", length(which.panel)-which.given+1, sep = ".")))
# pushViewport(viewport(x = 1 - (which.given-0.5)/length(which.panel),
# width = 1/length(which.panel),
# clip = trellis.par.get("clip")$strip,
# name = paste("strip.left.default", which.given, sep = ".")))
gp.text <-
gpar(col = par.strip.text$col,
alpha = par.strip.text$alpha,
lineheight = par.strip.text$lineheight,
fontfamily = par.strip.text$fontfamily,
fontface = lattice:::chooseFace(par.strip.text$fontface, par.strip.text$font),
cex = par.strip.text$cex)
name <- var.name[which.given]
level <- which.panel[which.given]
strip.names <- rep(strip.names, length.out = 2)
strip.levels <- rep(strip.levels, length.out = 2)
## str(shingle.intervals)
formatLabel <-
function(s,
abbreviate = par.strip.text$abbr,
minlength = par.strip.text$minl,
dot = par.strip.text$dot)
{
if (is.null(abbreviate)) abbreviate <- FALSE
if (is.null(minlength)) minlength <- 4
if (is.null(dot)) dot <- FALSE
if (abbreviate) abbreviate(s, minlength = minlength, dot = dot)
else s
}
factor.levels <- formatLabel(factor.levels)
if (!is.null(shingle.intervals))
{
## This usually indicates shingles, as opposed to factors.
## 'style' will be completely ignored, and shingle.intervals
## encoded using bg and fg. Names and levels are both game.
if (horizontal)
type <- "strip"
else
type <- "strip.left"
grid.rect(name = trellis.grobname("bg", type = type),
gp = gpar(fill = bg, col = bg))
t <- range(shingle.intervals)
r <- (range(shingle.intervals[level,]) - t[1]) / diff(t)
if (horizontal)
grid.rect(x = unit(r %*% c(.5,.5),"npc"),
width = max(unit(c(diff(r), 1), c("npc", "mm"))),
name = trellis.grobname("fg", type="strip"),
gp = gpar(col = fg, fill = fg))
else
grid.rect(y = unit(r %*% c(.5,.5),"npc"),
height = max(unit( c(diff(r), 1), c("npc", "mm"))),
name = trellis.grobname("fg", type="strip.left"),
gp = gpar(col = fg, fill = fg))
lattice:::paste.and.draw(name, factor.levels[level],
sep = sep,
horizontal = horizontal,
showl = strip.names[2],
showr = strip.levels[2],
gp = gp.text)
}
else
{
## Behaviour depends on 'style'. Will separate out coloring
## and text based on 'style'.
num <- length(factor.levels)
## coloring:
## background: all except style = 2
if (style != 2) {
if (horizontal)
type <- "strip"
else
type <- "strip.left"
grid.rect(name = trellis.grobname("bg", type = type),
gp = gpar(fill = bg, col = bg))
}
## foreground: needed only for style = 2, 3 and 4
if (num > 0 && style %in% c(2, 3, 4))
{
if (horizontal)
{
grid.rect(x = unit((2*level-1)/(2*num), "npc"),
width = unit(1/num, "npc"),
name = trellis.grobname("fg", type = "strip"),
gp = gpar(fill = fg, col = fg))
}
else
{
grid.rect(y = unit((2*level-1)/(2*num), "npc"),
height = unit(1/num, "npc"),
name = trellis.grobname("fg", type = "strip.left"),
gp = gpar(fill = fg, col = fg))
}
}
## text: [names|levels] centered only if style = 1 or 3
if (style %in% c(1, 3))
{
lattice:::paste.and.draw(name, factor.levels[level],
sep = sep,
horizontal = horizontal,
showl = strip.names[1],
showr = strip.levels[1],
gp = gp.text)
}
## remaining cases
else if (num > 0)
{
## either all levels or only one
lid <- if (style %in% c(2, 4)) 1:num else level
if (horizontal)
{
grid.text(label = factor.levels[lid],
x = (2 * lid - 1) / (2 * num),
name = trellis.grobname("fg", type = "strip"),
gp = gp.text)
}
else
{
grid.text(label = factor.levels[lid],
y = (2 * lid - 1) / (2 * num),
rot = 90,
name = trellis.grobname("fg", type = "strip.left"),
gp = gp.text)
}
}
}
upViewport()
## border is drawn with clipping off
if (horizontal)
pushViewport(viewport(y = (length(which.panel)-which.given+1-0.5)/length(which.panel),
height = 1/length(which.panel),
clip = "off",
name = paste("strip.default.off", length(which.panel)-which.given+1, sep = ".")))
# pushViewport(viewport(y = (which.given-0.5)/length(which.panel),
# height = 1/length(which.panel),
# clip = "off",
# name = paste("strip.default.off", which.given, sep = ".")))
else
pushViewport(viewport(x = 1 - (length(which.panel)-which.given+1-0.5)/length(which.panel),
width = 1/length(which.panel),
clip = "off",
name = paste("strip.left.default.off", length(which.panel)-which.given+1, sep = ".")))
# pushViewport(viewport(x = 1 - (which.given-0.5)/length(which.panel),
# width = 1/length(which.panel),
# clip = "off",
# name = paste("strip.left.default.off", which.given, sep = ".")))
strip.border <- trellis.par.get("strip.border")
## draw border for strip
if (horizontal)
type <- "strip"
else
type <- "strip.left"
grid.rect(name = trellis.grobname("border", type = type),
gp =
gpar(col = rep(strip.border$col, length.out = which.given)[which.given],
lty = rep(strip.border$lty, length.out = which.given)[which.given],
lwd = rep(strip.border$lwd, length.out = which.given)[which.given],
alpha = rep(strip.border$alpha, length.out = which.given)[which.given],
fill = "transparent"))
upViewport()
}
plot.trellisEx <-
function(x,
position = NULL, split = NULL,
more = FALSE, newpage = TRUE,
packet.panel = packet.panel.default,
draw.in = NULL,
panel.height = lattice.getOption("layout.heights")$panel,
panel.width = lattice.getOption("layout.widths")$panel,
save.object = lattice.getOption("save.object"),
panel.error = lattice.getOption("panel.error"),
prefix = NULL,
...)
{
## make sure we have a device open
# browser()
if (is.null(dev.list())) trellis.device()
else if (is.null(trellis.par.get()))
trellis.device(device = .Device, new = FALSE)
## if necessary, save current settings and apply temporary
## settings in x$par.settings
if (!is.null(x$par.settings))
{
## save current state, restore later
opar <- trellis.par.get() ## get("lattice.theme", envir = .LatticeEnv)
trellis.par.set(theme = x$par.settings)
on.exit(trellis.par.set(opar, strict = 2L), add = TRUE)
}
## do the same for lattice.options
# browser()
if (!is.null(x$lattice.options))
{
## save current state, restore later
oopt <- lattice.options(x$lattice.options)
# oopt <- lattice.options()
# lattice.options(x$lattice.options)
on.exit(lattice.options(oopt), add = TRUE)
}
## We'll also allow arguments to print.trellis (or plot.trellis)
## to be included within a trellis object. Partial matching is
## not done.
if (!is.null(x$plot.args))
{
supplied <- names(x$plot.args)
## Can't think of a clean way, so...
if ("position" %in% supplied && missing(position)) position <- x$plot.args$position
if ("split" %in% supplied && missing(split)) split <- x$plot.args$split
if ("more" %in% supplied && missing(more)) more <- x$plot.args$more
if ("newpage" %in% supplied && missing(newpage)) newpage <- x$plot.args$newpage
if ("packet.panel" %in% supplied && missing(packet.panel)) packet.panel <- x$plot.args$packet.panel
if ("draw.in" %in% supplied && missing(draw.in)) draw.in <- x$plot.args$draw.in
if ("panel.height" %in% supplied && missing(panel.height)) panel.height <- x$plot.args$panel.height
if ("panel.width" %in% supplied && missing(panel.width)) panel.width <- x$plot.args$panel.width
if ("save.object" %in% supplied && missing(save.object)) save.object <- x$plot.args$save.object
if ("panel.error" %in% supplied && missing(panel.error)) panel.error <- x$plot.args$panel.error
if ("prefix" %in% supplied && missing(prefix)) prefix <- x$plot.args$prefix
}
# browser()
panel.error <- lattice:::getFunctionOrName(panel.error)
bg <- trellis.par.get("background")$col
new <- newpage && !lattice:::lattice.getStatus("print.more") && is.null(draw.in)
if (!is.null(draw.in))
{
depth <- downViewport(draw.in)
on.exit(upViewport(depth), add = TRUE)
}
on.exit(lattice:::lattice.setStatus(print.more = more), add = TRUE)
usual <- (is.null(position) && is.null(split))
## This means this plot will be the first one on a new page, so reset counter
if (new) lattice:::lattice.setStatus(plot.index = 0L)
## get default prefix for grid viewport/object names
pindex <- 1L + lattice:::lattice.getStatus("plot.index")
if (is.null(prefix)) prefix <- sprintf("plot_%02g", pindex)
lattice:::lattice.setStatus(plot.index = pindex)
## Set this so that panel and axis functions can use it, but set
## it again before exiting (in case some user action has changed
## it in the meantime) so that further calls to trellis.focus()
## etc. can use it.
lattice:::lattice.setStatus(current.prefix = prefix)
on.exit(lattice:::lattice.setStatus(current.prefix = prefix), add = TRUE)
# browser()
## Initialize list for this prefix
# (lattice:::.LatticeEnv)$lattice.status[[prefix]] <- lattice:::.defaultLatticePrefixStatus()
## Equivalently
## lattice.setStatus(structure(list(.defaultLatticePrefixStatus()),
## names = prefix))
## save the current object, if so requested. This used to be done
## at the end, so that it wouldn't happen if there were errors
## during printing. However, doing this now will allow things
## like trellis.panelArgs() to work in panel/axis functions, which
## I think is a better trade-off.
## FIXME: the problem with this is that if, e.g., the panel
## function calls print.trellis(), then the last object is not
## what one would expect.
if (save.object)
{
lattice:::lattice.setStatus(current.plot.saved = TRUE, prefix = prefix)
## assign("last.object", x, envir = .LatticeEnv)
lattice:::lattice.setStatus(last.object = x, prefix = prefix)
}
else
lattice:::lattice.setStatus(current.plot.saved = FALSE, prefix = prefix)
global.gpar <-
do.call(gpar,
lattice:::updateList(trellis.par.get("grid.pars"),
list(fontsize = trellis.par.get("fontsize")$text)))
if (!is.null(position))
{
stopifnot (length(position) == 4)
if (new)
{
grid.newpage()
grid.rect(name=trellis.grobname("background", type=""),
gp = gpar(fill = bg, col = "transparent"))
}
pushViewport(viewport(x = position[1], y = position[2],
width = position[3] - position[1],
height = position[4] - position[2],
just = c("left","bottom"),
name = trellis.vpname("position", prefix = prefix)))
if (!is.null(split))
{
stopifnot (length(split) == 4)
pushViewport(viewport(layout = grid.layout(nrow = split[4], ncol = split[3]),
name = trellis.vpname("split", prefix = prefix) ))
pushViewport(viewport(layout.pos.row = split[2], layout.pos.col = split[1],
name = trellis.vpname("split.location", prefix = prefix) ))
}
}
else if (!is.null(split))
{
stopifnot(length(split) == 4)
if (new)
{
grid.newpage()
grid.rect(name = trellis.grobname("background", type=""),
gp = gpar(fill = bg, col = "transparent"))
}
pushViewport(viewport(layout = grid.layout(nrow = split[4], ncol = split[3]),
name = trellis.vpname("split", prefix = prefix) ))
pushViewport(viewport(layout.pos.row = split[2], layout.pos.col = split[1],
name = trellis.vpname("split.location", prefix = prefix) ))
}
## order.cond will be a multidimensional array, with
## length(dim(order.cond)) = number of conditioning
## variables. It's a numeric vector 1:(number.of.panels), with
## dim() = c(nlevels(g1), ..., nlevels(gn)), where g1, ..., gn are
## the conditioning variables.
## manipulating order.cond has 2 uses. Using normal indexing, the
## order of plots within a conditioning variable can be altered,
## or only a subset of the levels used. Also, using aperm, the
## order of conditioning can be altered.
## the information required to make the appropriate permutation
## and indexing is in the components index.cond and perm.cond of
## the trellis object
### FIXME: need some thinking here.
## ## Original version (up to 0.13 series):
## order.cond <- seq_len(prod(sapply(x$condlevels, length)))
## dim(order.cond) <- sapply(x$condlevels, length)
## ## first subset, then permute
## order.cond <- do.call("[", c(list(order.cond), x$index.cond, list(drop = FALSE)))
## order.cond <- aperm(order.cond, perm = x$perm.cond)
## ## New version:
## used.condlevels corresponds to the indexed and permuted object.
## These also have to be integer indices rather than character
## labels (necessary for 'packet.panel' computations).
## original.condlevels is required to interpret the results of
## packet.panel and associate them with packets in the original
## object (which are defined in terms of the original levels)
original.condlevels <-
used.condlevels <-
lapply(x$condlevels, function(x) seq_along(x))
used.condlevels <-
mapply("[", used.condlevels, x$index.cond,
MoreArgs = list(drop = FALSE),
SIMPLIFY = FALSE)
used.condlevels <- used.condlevels[x$perm.cond]
inverse.permutation <- order(x$perm.cond) # used later
## an array giving packet numbers corresponding to
## original.condlevels. The idea is to be able to figure out the
## packet given levels of the conditioning variables. The packets
## are naturally thought of as an array. The packet number simply
## counts positions of this array in the standard order
## (i.e. lower dimensions vary faster).
adim <- sapply(original.condlevels, length)
packet.array <- seq_len(prod(adim))
dim(packet.array) <- adim
## FIXME: trying to find a way to make order.cond unnecessary may
## make things simpler, but that's not a very immediate concern
## (and not clear how difficult either).
## order.cond <- seq_len(prod(sapply(x$condlevels, length)))
## dim(order.cond) <- sapply(x$condlevels, length)
## first subset, then permute
## order.cond <- do.call("[", c(list(order.cond), x$index.cond, list(drop = FALSE)))
## order.cond <- aperm(order.cond, perm = x$perm.cond)
## order.cond will be used as indices for (exactly) the following
## 1. panel.args
## 2. x.limits
## 3. y.limits
## may need x$(index|perm).cond later for strip drawing
## cond.max.levels <- dim(order.cond)
cond.max.levels <- sapply(used.condlevels, length)
number.of.cond <- length(cond.max.levels)
panel.layout <-
lattice:::compute.layout(x$layout, cond.max.levels, skip = x$skip)
panel <- lattice:::getFunctionOrName(x$panel) # shall use "panel" in do.call
strip <- lattice:::getFunctionOrName(x$strip)
strip.left <- lattice:::getFunctionOrName(x$strip.left)
axis.line <- trellis.par.get("axis.line")
axis.text <- trellis.par.get("axis.text")
## make sure aspect ratio is preserved for aspect != "fill" but
## this may not always be what's expected. In fact, aspect should
## be "fill" whenever panel.width or panel.height are non-default.
## panel.width <- 1
if (!x$aspect.fill)
panel.height[[1]] <- x$aspect.ratio * panel.width[[1]]
## Evaluate the legend / key grob(s):
legend <- lattice:::evaluate.legend(x$legend)
## legend is now a list of `grob's along with placement info
xaxis.lty <-
if (is.logical(x$x.scales$lty)) axis.line$lty
else x$x.scales$lty
xaxis.lwd <-
if (is.logical(x$x.scales$lwd)) axis.line$lwd
else x$x.scales$lwd
xaxis.col.line <-
if (is.logical(x$x.scales$col.line)) axis.line$col
else x$x.scales$col.line
xaxis.col.text <-
if (is.logical(x$x.scales$col)) axis.text$col
else x$x.scales$col
xaxis.alpha.line <-
if (is.logical(x$x.scales$alpha.line)) axis.line$alpha
else x$x.scales$alpha.line
xaxis.alpha.text <-
if (is.logical(x$x.scales$alpha)) axis.text$alpha
else x$x.scales$alpha
xaxis.font <-
if (is.logical(x$x.scales$font)) axis.text$font
else x$x.scales$font
xaxis.fontface <-
if (is.logical(x$x.scales$fontface)) axis.text$fontface
else x$x.scales$fontface
xaxis.fontfamily <-
if (is.logical(x$x.scales$fontfamily)) axis.text$fontfamily
else x$x.scales$fontfamily
xaxis.lineheight <-
if (is.logical(x$x.scales$lineheight)) axis.text$lineheight
else x$x.scales$lineheight
xaxis.cex <-
if (is.logical(x$x.scales$cex)) rep(axis.text$cex, length.out = 2)
else x$x.scales$cex
xaxis.rot <-
if (is.logical(x$x.scales$rot)) c(0, 0)
else x$x.scales$rot
yaxis.lty <-
if (is.logical(x$y.scales$lty)) axis.line$lty
else x$y.scales$lty
yaxis.lwd <-
if (is.logical(x$y.scales$lwd)) axis.line$lwd
else x$y.scales$lwd
yaxis.col.line <-
if (is.logical(x$y.scales$col.line)) axis.line$col
else x$y.scales$col.line
yaxis.col.text <-
if (is.logical(x$y.scales$col)) axis.text$col
else x$y.scales$col
yaxis.alpha.line <-
if (is.logical(x$y.scales$alpha.line)) axis.line$alpha
else x$y.scales$alpha.line
yaxis.alpha.text <-
if (is.logical(x$y.scales$alpha)) axis.text$alpha
else x$y.scales$alpha
yaxis.font <-
if (is.logical(x$y.scales$font)) axis.text$font
else x$y.scales$font
yaxis.fontface <-
if (is.logical(x$y.scales$fontface)) axis.text$fontface
else x$y.scales$fontface
yaxis.fontfamily <-
if (is.logical(x$y.scales$fontfamily)) axis.text$fontfamily
else x$y.scales$fontfamily
yaxis.lineheight <-
if (is.logical(x$y.scales$lineheight)) axis.text$lineheight
else x$y.scales$lineheight
yaxis.cex <-
if (is.logical(x$y.scales$cex)) rep(axis.text$cex, length.out = 2)
else 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.out = number.of.cond)
strip.col.default.fg <-
rep(trellis.par.get("strip.shingle")$col,
length.out = number.of.cond)
strip.border <-
lapply(trellis.par.get("strip.border"),
function(x) rep(x, length.out = number.of.cond))
## Start layout calculations when only number of panels per page
## is pecified (this refers to the layout argument, not grid
## layouts)
## using device dimensions to calculate default layout:
if (panel.layout[1] == 0)
{
ddim <- par("din")
device.aspect <- ddim[2] / ddim[1]
panel.aspect <- panel.height[[1]] / panel.width[[1]]
plots.per.page <- panel.layout[2]
m <- max (1, round(sqrt(panel.layout[2] * device.aspect / panel.aspect)))
## changes made to fix bug (PR#1744)
n <- ceiling(plots.per.page/m)
m <- ceiling(plots.per.page/n)
panel.layout[1] <- n
panel.layout[2] <- m
}
## End layout calculations
plots.per.page <- panel.layout[1] * panel.layout[2]
cols.per.page <- panel.layout[1]
rows.per.page <- panel.layout[2]
number.of.pages <- panel.layout[3]
lattice:::lattice.setStatus(current.plot.multipage = number.of.pages > 1, prefix = prefix)
## these will also eventually be 'status' variables
current.panel.positions <- matrix(0, rows.per.page, cols.per.page)
current.packet.positions <- matrix(0, rows.per.page, cols.per.page)
current.cond.levels <- vector(mode = "list", length = rows.per.page * cols.per.page)
dim(current.cond.levels) <- c(rows.per.page, cols.per.page)
## ## following now relegated to packet.panel
## skip <- rep(x$skip, length.out = number.of.pages * rows.per.page * cols.per.page)
x.alternating <- rep(x$x.scales$alternating, length.out = cols.per.page)
y.alternating <- rep(x$y.scales$alternating, length.out = rows.per.page)
x.relation.same <- x$x.scales$relation == "same"
y.relation.same <- x$y.scales$relation == "same"
## get lists for main, sub, xlab, ylab
# browser()
main <-
lattice:::grobFromLabelList(lattice:::getLabelList(x$main,
trellis.par.get("par.main.text")),
name = trellis.grobname("main", type=""))
sub <-
lattice:::grobFromLabelList(lattice:::getLabelList(x$sub,
trellis.par.get("par.sub.text")),
name = trellis.grobname("sub", type=""))
xlab <-
lattice:::grobFromLabelList(lattice:::getLabelList(x$xlab,
trellis.par.get("par.xlab.text"),
x$xlab.default),
name = trellis.grobname("xlab", type=""))
ylab <-
lattice:::grobFromLabelList(lattice:::getLabelList(x$ylab,
trellis.par.get("par.ylab.text"),
x$ylab.default),
name = trellis.grobname("ylab", type=""),
orient = 90)
xlab.top <-
lattice:::grobFromLabelList(lattice:::getLabelList(x$xlab.top,
trellis.par.get("par.xlab.text")),
name = trellis.grobname("xlab.top", type=""))
ylab.right <-
lattice:::grobFromLabelList(lattice:::getLabelList(x$ylab.right,
trellis.par.get("par.ylab.text")),
name = trellis.grobname("ylab.right", type=""),
orient = 90)
# groupBy
## get par.strip.text
par.strip.text <- trellis.par.get("add.text")
par.strip.text$lines <- 1
if (!is.null(x$par.strip.text))
par.strip.text[names(x$par.strip.text)] <- x$par.strip.text
## Shall calculate the per page Grid layout now:
## this layout will now be used for each page (this is quite
## complicated and unfortunately very convoluted)
layoutCalculations <-
lattice:::calculateGridLayout(x,
rows.per.page, cols.per.page,
number.of.cond,
panel.height, panel.width,
main, sub,
xlab, ylab, xlab.top, ylab.right,
x.alternating, y.alternating,
x.relation.same, y.relation.same,
xaxis.rot, yaxis.rot,
xaxis.cex, yaxis.cex,
xaxis.lineheight, yaxis.lineheight,
par.strip.text,
legend)
lattice:::lattice.setStatus(layout.details = layoutCalculations, prefix = prefix)
lattice:::lattice.setStatus(as.table = x$as.table, prefix = prefix)
page.layout <- layoutCalculations$page.layout
pos.heights <- layoutCalculations$pos.heights
pos.widths <- layoutCalculations$pos.widths
n.row <- lattice:::layoutNRow(page.layout)
n.col <- lattice:::layoutNCol(page.layout)
## commence actual plotting
cond.current.level <- rep(1, number.of.cond)
## this vector represents the combination of levels of the
## conditioning variables for the current panel. We're changing
## to a new scheme which should make this unnecessary, but we need
## to keep it for now to ensure the first page is drawn (kinda
## stupid, but that part of the code was there to ensure that an
## `empty' trellis object doesn't waste a page. Actually, it
## might be redundant, since in that case number.of.pages should
## be 0. FIXME: Check it out)
panel.counter <- 0
## panel.number is available as an optional argument to the panel
## function (FIXME: to be deprecated). It's a strictly increasing
## sequential counter keeping track of which panel is being drawn.
## This is usually the same as, but can be different from
## packet.number, which is an index to which packet combination is
## being used.
## FIXME: what happens when number of pages is 0?
## message("no of pages: ", number.of.pages)
for (page.number in seq_len(number.of.pages))
{
if (TRUE) ## FIXME: remove this after a few versions and reformat
{
## In older versions, we used to decide here whether a new
## page was actually needed, i.e., whether there is
## anything to draw (o.w., why waste a page?). This is no
## longer possible because we don't know a priori what
## packet.panel() will return.
if (usual)
{
if (new) grid.newpage()
grid.rect(name = trellis.grobname("background", type=""),
gp = gpar(fill = bg, col = "transparent"))
new <- TRUE
}
pushViewport(viewport(layout = page.layout,
gp = global.gpar,
name = trellis.vpname("toplevel", prefix = prefix)))
if (!is.null(main))
{
lattice:::drawInViewport(main,
viewport(layout.pos.row = pos.heights$main,
name= trellis.vpname("main", prefix = prefix)))
}
if (!is.null(sub))
{
lattice:::drawInViewport(sub,
viewport(layout.pos.row = pos.heights$sub,
name= trellis.vpname("sub", prefix = prefix)))
}
if (!is.null(xlab))
{
lattice:::drawInViewport(xlab,
viewport(layout.pos.row = pos.heights$xlab,
layout.pos.col = pos.widths$panel,
name= trellis.vpname("xlab", prefix = prefix)))
}
if (!is.null(ylab))
{
lattice:::drawInViewport(ylab,
viewport(layout.pos.col = pos.widths$ylab,
layout.pos.row = pos.heights$panel,
name= trellis.vpname("ylab", prefix = prefix)))
}
if (!is.null(xlab.top))
{
lattice:::drawInViewport(xlab.top,
viewport(layout.pos.row = pos.heights$xlab.top,
layout.pos.col = pos.widths$panel,
name= trellis.vpname("xlab.top", prefix = prefix)))
}
if (!is.null(ylab.right))
{
lattice:::drawInViewport(ylab.right,
viewport(layout.pos.col = pos.widths$ylab.right,
layout.pos.row = pos.heights$panel,
name= trellis.vpname("ylab.right", prefix = prefix)))
}
last.panel <- prod(sapply(x$index.cond, length))
## Create a viewport encompassing all panels and strips,
## but don't do anything in it. This is useful later for
## trellis.focus() like operations.
rowRange <- with(pos.heights, range(panel, strip, axis.panel))
colRange <- with(pos.widths, range(panel, strip.left, axis.panel))
pushViewport(viewport(layout.pos.row = rowRange,
layout.pos.col = colRange,
clip = "off",
name = trellis.vpname("figure")))
upViewport()
## preliminary loop through possible positions, doing some
## calculations that allow some helpful status variables
## to be set.
## first, initialize status variables
current.panel.positions[, ] <- 0
current.packet.positions[, ] <- 0
current.cond.levels[, ] <- list(NULL)
for (row in seq_len(rows.per.page))
for (column in seq_len(cols.per.page))
{
## levels being used in this panel
which.packet <-
packet.panel(layout = panel.layout,
condlevels = used.condlevels,
page = page.number,
row = row,
column = column,
skip = x$skip)
if (!is.null(which.packet))
{
## permute to restore original order
which.packet <- which.packet[inverse.permutation]
current.cond.levels[[row, column]] <- which.packet
## packet.number should be same as packet.array[which.packet]
## ^^^^^^^^^^^
## (length not fixed)
packet.number <-
do.call("[", c(list(x = packet.array), as.list(which.packet)))
current.packet.positions[row, column] <- packet.number
## packet.number retrieves the appropriate
## entry of panel.args and [xy].limits. It has
## to be this way because otherwise
## non-trivial orderings will not work.
## But we also provide a simple incremental
## counter that may be used as a panel
## function argument
panel.counter <- panel.counter + 1
current.panel.positions[row, column] <- panel.counter
}
}
lattice:::lattice.setStatus(current.cond.levels = current.cond.levels, prefix = prefix)
lattice:::lattice.setStatus(current.panel.positions = current.panel.positions, prefix = prefix)
lattice:::lattice.setStatus(current.packet.positions = current.packet.positions, prefix = prefix)
## loop through positions again, doing the actual drawing
## this time
for (row in seq_len(rows.per.page))
for (column in seq_len(cols.per.page))
{
lattice:::lattice.setStatus(current.focus.row = row,
current.focus.column = column,
prefix = prefix)
which.packet <- which.packet(prefix = prefix)
if (!is.null(which.packet))
{
packet.number <- packet.number(prefix = prefix)
panel.number <- panel.number(prefix = prefix) ## needed? FIXME
## this gives the row position from the bottom
actual.row <- if (x$as.table)
(rows.per.page-row+1) else row
pos.row <- pos.heights$panel[row]
pos.col <- pos.widths$panel[column]
# browser()
xscale.comps <-
if (x.relation.same)
x$xscale.components(lim = x$x.limits,
## (FIXME: needs work) packet.list = ...
top = TRUE,
## rest passed on to
## calculateAxisComponents
## in the default
## case:
at = x$x.scales$at,
used.at = x$x.used.at,
num.limit = x$x.num.limit,
labels = x$x.scales$labels,
logsc = x$x.scales$log,
abbreviate = x$x.scales$abbreviate,
minlength = x$x.scales$minlength,
n = x$x.scales$tick.number,
format.posixt = x$x.scales$format)
else
x$xscale.components(lim = x$x.limits[[packet.number]],
## FIXME: needs work packet.list = ...
top = FALSE,
## rest passed on to
## calculateAxisComponents
## in the default
## case:
at = if (is.list(x$x.scales$at))
x$x.scales$at[[packet.number]]
else x$x.scales$at,
used.at = x$x.used.at[[packet.number]],
num.limit = x$x.num.limit[[packet.number]],
labels =
if (is.list(x$x.scales$labels))
x$x.scales$labels[[packet.number]]
else x$x.scales$labels,
logsc = x$x.scales$log,
abbreviate = x$x.scales$abbreviate,
minlength = x$x.scales$minlength,
n = x$x.scales$tick.number,
format.posixt = x$x.scales$format)
yscale.comps <-
if (y.relation.same)
x$yscale.components(lim = x$y.limits,
## FIXME: needs work packet.list = ...
right = TRUE,
## rest passed on to
## calculateAxisComponents
## in the default
## case:
at = x$y.scales$at,
used.at = x$y.used.at,
num.limit = x$y.num.limit,
labels = x$y.scales$labels,
logsc = x$y.scales$log,
abbreviate = x$y.scales$abbreviate,
minlength = x$y.scales$minlength,
n = x$y.scales$tick.number,
format.posixt = x$y.scales$format)
else
x$yscale.components(lim = x$y.limits[[packet.number]],
## FIXME: needs work packet.list = ...
right = FALSE,
## rest passed on to
## calculateAxisComponents
## in the default
## case:
at = if (is.list(x$y.scales$at))
x$y.scales$at[[packet.number]]
else x$y.scales$at,
used.at = x$y.used.at[[packet.number]],
num.limit = x$y.num.limit[[packet.number]],
labels =
if (is.list(x$y.scales$labels))
x$y.scales$labels[[packet.number]]
else x$y.scales$labels,
logsc = x$y.scales$log,
abbreviate = x$y.scales$abbreviate,
minlength = x$y.scales$minlength,
n = x$y.scales$tick.number,
format.posixt = x$y.scales$format)
xscale <- xscale.comps$num.limit
yscale <- yscale.comps$num.limit
############################################
### drawing panel background ##
############################################
pushViewport(viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col,
xscale = xscale,
yscale = yscale,
clip = trellis.par.get("clip")$panel,
name =
trellis.vpname("panel",
column = column,
row = row,
prefix = prefix,
clip.off = FALSE)))
panel.bg <- trellis.par.get("panel.background")
if (!is.null(panel.bg$col) && (panel.bg$col != "transparent"))
panel.fill(col = panel.bg$col)
upViewport()
############################################
### drawing the axes ##
############################################
### Note: axes should always be drawn before the panel, so that
### background grids etc. can be drawn.
### whether or not axes are drawn, we'll create viewports for them
### anyway, so that users can later interactively add axes/other stuff
### if they wish. First up, we'll have a 'strip.column.row.off'
### viewport for the top axes, then another one for those on the left
### (there can be strips on the left too), and then a
### 'panel.column.row.off' viewport for the other 2 (no strips allowed
### there). The names may seem a bit unintuitive, and perhaps they
### are, but some justification is provided in help(trellis.focus)
pushViewport(viewport(layout.pos.row = pos.row - 1,
layout.pos.col = pos.col,
xscale = xscale,
clip = "off",
name =
trellis.vpname("strip",
column = column,
row = row,
prefix = prefix,
clip.off = TRUE)))
## X-axis above
x$axis(side = "top",
scales = x$x.scales,
components = xscale.comps,
as.table = x$as.table,
rot = xaxis.rot[2],
text.col = xaxis.col.text,
text.alpha = xaxis.alpha.text,
text.cex = xaxis.cex[2],
text.font = xaxis.font,
text.fontfamily = xaxis.fontfamily,
text.fontface = xaxis.fontface,
text.lineheight = xaxis.lineheight,
line.col = xaxis.col.line,
line.lty = xaxis.lty,
line.lwd = xaxis.lwd,
line.alpha = xaxis.alpha.line,
prefix = prefix)
upViewport()
## Y-axis to the left
pushViewport(viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col - 1,
yscale = yscale,
clip = "off",
name =
trellis.vpname("strip.left",
column = column,
row = row,
prefix = prefix,
clip.off = TRUE)))
x$axis(side = "left",
scales = x$y.scales,
components = yscale.comps,
as.table = x$as.table,
rot = yaxis.rot[1],
text.col = yaxis.col.text,
text.alpha = yaxis.alpha.text,
text.cex = yaxis.cex[1],
text.font = yaxis.font,
text.fontfamily = yaxis.fontfamily,
text.fontface = yaxis.fontface,
text.lineheight = yaxis.lineheight,
line.col = yaxis.col.line,
line.lty = yaxis.lty,
line.lwd = yaxis.lwd,
line.alpha = yaxis.alpha.line,
prefix = prefix)
upViewport()
## X-axis bottom and Y-axis right
pushViewport(viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col,
xscale = xscale,
yscale = yscale,
clip = "off",
name =
trellis.vpname("panel",
column = column,
row = row,
prefix = prefix,
clip.off = TRUE)))
## X-axis below
x$axis(side = "bottom",
scales = x$x.scales,
components = xscale.comps,
as.table = x$as.table,
rot = xaxis.rot[1],
text.col = xaxis.col.text,
text.alpha = xaxis.alpha.text,
text.cex = xaxis.cex[1],
text.font = xaxis.font,
text.fontfamily = xaxis.fontfamily,
text.fontface = xaxis.fontface,
text.lineheight = xaxis.lineheight,
line.col = xaxis.col.line,
line.lty = xaxis.lty,
line.lwd = xaxis.lwd,
line.alpha = xaxis.alpha.line,
prefix = prefix)
## Y-axis to the right
x$axis(side = "right",
scales = x$y.scales,
components = yscale.comps,
as.table = x$as.table,
rot = yaxis.rot[2],
text.col = yaxis.col.text,
text.alpha = yaxis.alpha.text,
text.cex = yaxis.cex[2],
text.font = yaxis.font,
text.fontfamily = yaxis.fontfamily,
text.fontface = yaxis.fontface,
text.lineheight = yaxis.lineheight,
line.col = yaxis.col.line,
line.lty = yaxis.lty,
line.lwd = yaxis.lwd,
line.alpha = yaxis.alpha.line,
prefix = prefix)
## N.B.: We'll need this viewport again later
## to draw a border around it. However, this
## must be postponed till after the panel is
## drawn, since otherwise the border is liable
## to be obscured.
upViewport()
############################################
### done drawing axes ##
############################################
#########################################################################
### Draw the box around panels. This used to be done with clipping ##
### on, which caused some subtle and apparently puzzling side effects. ##
#########################################################################
downViewport(trellis.vpname("panel",
column = column,
row = row,
prefix = prefix,
clip.off = TRUE))
grid.rect(name = trellis.grobname("border",
type="panel"),
gp =
gpar(col = axis.line$col,
lty = axis.line$lty,
lwd = axis.line$lwd,
alpha = axis.line$alpha,
fill = "transparent"))
upViewport()
############################################
### drawing the panel ##
############################################
## viewport already created for drawing background
downViewport(trellis.vpname("panel",
column = column,
row = row,
prefix = prefix,
clip.off = FALSE))
## pushViewport(viewport(layout.pos.row = pos.row,
## layout.pos.col = pos.col,
## xscale = xscale,
## yscale = yscale,
## clip = trellis.par.get("clip")$panel,
## name =
## trellis.vpname("panel",
## column = column,
## row = row,
## prefix = prefix,
## clip.off = FALSE)))
pargs <- c(x$panel.args[[packet.number]],
x$panel.args.common) #,
## FIXME: include prefix = prefix? Could be
## important in very rare cases, but let's
## wait till someone actually has a relevant
## use-case.
## if (!("..." %in% names(formals(panel))))
## pargs <- pargs[intersect(names(pargs), names(formals(panel)))]
## if (is.null(panel.error))
## do.call("panel", pargs)
## else
## tryCatch(do.call("panel", pargs),
## error = function(e) panel.error(e))
if (is.null(panel.error))
lattice:::checkArgsAndCall(panel, pargs)
else
tryCatch(lattice:::checkArgsAndCall(panel, pargs),
error = function(e) panel.error(e))
upViewport()
############################################
### finished drawing panel ##
############################################
#########################################
### draw strip(s) on top ###
#########################################
if (!is.logical(strip)) # logical <==> FALSE
{
pushViewport(viewport(layout.pos.row = pos.row - 1,
layout.pos.col = pos.col,
clip = "off", ## was: trellis.par.get("clip")$strip,
name =
trellis.vpname("strip",
column = column,
row = row,
prefix = prefix,
clip.off = FALSE)))
for(i in seq_len(number.of.cond))
{
## Here, by which.given, I mean which
## in the original order, not the
## permuted order
##reversed the orignal order of strip plotting
# browser()
which.given <- x$perm.cond[i]
which.panel <- which.packet
lattice:::lattice.setStatus(current.which.given =
which.given,
current.which.panel =
which.panel,
prefix = prefix)
strip(which.given = which.given,
which.panel = which.panel,
## panel.number = panel.number,
## packet.number = packet.number,
var.name = names(x$condlevels),
factor.levels = as.character(x$condlevels[[x$perm.cond[i]]]),
shingle.intervals = if (is.list(x$condlevels[[x$perm.cond[i]]]))
do.call("rbind", x$condlevels[[x$perm.cond[i]]]) else NULL,
horizontal = TRUE,
bg = strip.col.default.bg[i],
fg = strip.col.default.fg[i],
par.strip.text = par.strip.text)
}
upViewport()
}
#########################################
### draw strip(s) on left ###
#########################################
if (!is.logical(strip.left)) # logical <==> FALSE
{
pushViewport(viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col - 1,
clip = trellis.par.get("clip")$strip,
name =
trellis.vpname("strip.left",
column = column,
row = row,
prefix = prefix,
clip.off = FALSE)))
for(i in seq_len(number.of.cond))
{
## Here, by which.given, I mean which
## in the original packet order, not
## the permuted order
which.given <- x$perm.cond[i]
which.panel <- which.packet
lattice:::lattice.setStatus(current.which.given =
which.given,
current.which.panel =
which.panel,
prefix = prefix)
strip.left(which.given = which.given,
which.panel = which.panel,
## panel.number = panel.number,
## packet.number = packet.number,
var.name = names(x$condlevels),
factor.levels = as.character(x$condlevels[[x$perm.cond[i]]]),
shingle.intervals = if (is.list(x$condlevels[[x$perm.cond[i]]]))
do.call("rbind", x$condlevels[[x$perm.cond[i]]]) else NULL,
horizontal = FALSE,
bg = strip.col.default.bg[i],
fg = strip.col.default.fg[i],
par.strip.text = par.strip.text)
}
upViewport()
}
}
}
## legend / key plotting
if (!is.null(legend))
{
locs <- names(legend)
for (i in seq_along(legend))
{
key.space <- locs[i]
key.gf <- legend[[i]]$obj
switch(key.space,
left =
lattice:::drawInViewport(key.gf,
viewport(layout.pos.col = pos.widths$key.left,
layout.pos.row = range(pos.heights$panel, pos.heights$strip),
name = trellis.vpname("legend", side = "left", prefix = prefix))),
right =
lattice:::drawInViewport(key.gf,
viewport(layout.pos.col = pos.widths$key.right,
layout.pos.row = range(pos.heights$panel, pos.heights$strip),
name = trellis.vpname("legend", side = "right", prefix = prefix))),
top =
lattice:::drawInViewport(key.gf,
viewport(layout.pos.row = pos.heights$key.top,
layout.pos.col = range(pos.widths$panel, pos.widths$strip.left),
name = trellis.vpname("legend", side = "top", prefix = prefix))),
bottom =
lattice:::drawInViewport(key.gf,
viewport(layout.pos.row = pos.heights$key.bottom,
layout.pos.col = range(pos.widths$panel, pos.widths$strip.left),
name = trellis.vpname("legend", side = "bottom", prefix = prefix))),
inside = {
## There are two choices here ---
## either treat the whole figure region
## as the rectangle, or use just the
## region covered by the panels. This
## is user-controllable through
## lattice.options("legend.bbox").
legend.bbox <- lattice.getOption("legend.bbox")
switch(legend.bbox,
full =
pushViewport(viewport(layout.pos.row = c(1, n.row),
layout.pos.col = c(1, n.col),
name = trellis.vpname("legend.region", prefix = prefix))),
panel =
pushViewport(viewport(layout.pos.row = range(pos.heights$panel, pos.heights$strip),
layout.pos.col = range(pos.widths$panel, pos.widths$strip.left),
name = trellis.vpname("legend.region", prefix = prefix))))
key.corner <-
if (is.null(legend[[i]]$corner)) c(0,1)
else legend[[i]]$corner
key.x <-
if (is.null(legend[[i]]$x)) key.corner[1]
else legend[[i]]$x
key.y <-
if (is.null(legend[[i]]$y)) key.corner[2]
else legend[[i]]$y
lattice:::drawInViewport(key.gf,
viewport(x = unit(key.x, "npc") + unit(0.5 - key.corner[1], "grobwidth", list(key.gf)),
y = unit(key.y, "npc") + unit(0.5 - key.corner[2], "grobheight", list(key.gf)),
name = trellis.vpname("legend", side = "inside", prefix = prefix)))
upViewport(1)
})
}
}
pushViewport(viewport(layout.pos.row = c(1, n.row),
layout.pos.col = c(1, n.col),
name = trellis.vpname("page", prefix = prefix)))
if (!is.null(x$page)) x$page(page.number)
upViewport()
upViewport()
}
}
if (!is.null(position))
{
if (!is.null(split))
{
upViewport()
upViewport()
}
upViewport()
}
else if (!is.null(split))
{
upViewport()
upViewport()
}
lattice:::lattice.setStatus(current.focus.row = 0,
current.focus.column = 0,
vp.highlighted = FALSE,
vp.depth = 0, prefix = prefix)
invisible()
}
Try the QUALIFIER package in your browser
Any scripts or data that you put into this service are public.
QUALIFIER documentation built on Oct. 31, 2019, 3:24 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 stripEx plot.trellisEx
# this plot function is from lattice package,we just adjust the order
# of plotting,plot the box of panel first in order to prevent the actual plot
#region from being covered by the box,such as some svg annotations
# Author: mike
###############################################################################
##reverse the order of strip plotting for conditional vairables
#' @import grid
stripEx <-
function(which.given,
which.panel,
## packet.number,
## panel.number,
var.name,
factor.levels,
shingle.intervals = NULL,
strip.names = c(FALSE, TRUE),
strip.levels = c(TRUE, FALSE),
sep = " : ",
style = 1,
horizontal = TRUE,
## FIXME: not sure how to incorporate alpha in strip colors
bg = trellis.par.get("strip.background")$col[which.given],
fg = trellis.par.get("strip.shingle")$col[which.given],
par.strip.text = trellis.par.get("add.text"))
{
# browser()
if (horizontal)
pushViewport(viewport(y = (length(which.panel)-which.given+1-0.5)/length(which.panel),
height = 1/length(which.panel),
clip = trellis.par.get("clip")$strip,
name = paste("strip.default", length(which.panel)-which.given+1, sep = ".")))
# pushViewport(viewport(y = (which.given-0.5)/length(which.panel),
# height = 1/length(which.panel),
# clip = trellis.par.get("clip")$strip,
# name = paste("strip.default", which.given, sep = ".")))
else
pushViewport(viewport(x = 1 - (length(which.panel)-which.given+1-0.5)/length(which.panel),
width = 1/length(which.panel),
clip = trellis.par.get("clip")$strip,
name = paste("strip.left.default", length(which.panel)-which.given+1, sep = ".")))
# pushViewport(viewport(x = 1 - (which.given-0.5)/length(which.panel),
# width = 1/length(which.panel),
# clip = trellis.par.get("clip")$strip,
# name = paste("strip.left.default", which.given, sep = ".")))
gp.text <-
gpar(col = par.strip.text$col,
alpha = par.strip.text$alpha,
lineheight = par.strip.text$lineheight,
fontfamily = par.strip.text$fontfamily,
fontface = lattice:::chooseFace(par.strip.text$fontface, par.strip.text$font),
cex = par.strip.text$cex)
name <- var.name[which.given]
level <- which.panel[which.given]
strip.names <- rep(strip.names, length.out = 2)
strip.levels <- rep(strip.levels, length.out = 2)
## str(shingle.intervals)
formatLabel <-
function(s,
abbreviate = par.strip.text$abbr,
minlength = par.strip.text$minl,
dot = par.strip.text$dot)
{
if (is.null(abbreviate)) abbreviate <- FALSE
if (is.null(minlength)) minlength <- 4
if (is.null(dot)) dot <- FALSE
if (abbreviate) abbreviate(s, minlength = minlength, dot = dot)
else s
}
factor.levels <- formatLabel(factor.levels)
if (!is.null(shingle.intervals))
{
## This usually indicates shingles, as opposed to factors.
## 'style' will be completely ignored, and shingle.intervals
## encoded using bg and fg. Names and levels are both game.
if (horizontal)
type <- "strip"
else
type <- "strip.left"
grid.rect(name = trellis.grobname("bg", type = type),
gp = gpar(fill = bg, col = bg))
t <- range(shingle.intervals)
r <- (range(shingle.intervals[level,]) - t[1]) / diff(t)
if (horizontal)
grid.rect(x = unit(r %*% c(.5,.5),"npc"),
width = max(unit(c(diff(r), 1), c("npc", "mm"))),
name = trellis.grobname("fg", type="strip"),
gp = gpar(col = fg, fill = fg))
else
grid.rect(y = unit(r %*% c(.5,.5),"npc"),
height = max(unit( c(diff(r), 1), c("npc", "mm"))),
name = trellis.grobname("fg", type="strip.left"),
gp = gpar(col = fg, fill = fg))
lattice:::paste.and.draw(name, factor.levels[level],
sep = sep,
horizontal = horizontal,
showl = strip.names[2],
showr = strip.levels[2],
gp = gp.text)
}
else
{
## Behaviour depends on 'style'. Will separate out coloring
## and text based on 'style'.
num <- length(factor.levels)
## coloring:
## background: all except style = 2
if (style != 2) {
if (horizontal)
type <- "strip"
else
type <- "strip.left"
grid.rect(name = trellis.grobname("bg", type = type),
gp = gpar(fill = bg, col = bg))
}
## foreground: needed only for style = 2, 3 and 4
if (num > 0 && style %in% c(2, 3, 4))
{
if (horizontal)
{
grid.rect(x = unit((2*level-1)/(2*num), "npc"),
width = unit(1/num, "npc"),
name = trellis.grobname("fg", type = "strip"),
gp = gpar(fill = fg, col = fg))
}
else
{
grid.rect(y = unit((2*level-1)/(2*num), "npc"),
height = unit(1/num, "npc"),
name = trellis.grobname("fg", type = "strip.left"),
gp = gpar(fill = fg, col = fg))
}
}
## text: [names|levels] centered only if style = 1 or 3
if (style %in% c(1, 3))
{
lattice:::paste.and.draw(name, factor.levels[level],
sep = sep,
horizontal = horizontal,
showl = strip.names[1],
showr = strip.levels[1],
gp = gp.text)
}
## remaining cases
else if (num > 0)
{
## either all levels or only one
lid <- if (style %in% c(2, 4)) 1:num else level
if (horizontal)
{
grid.text(label = factor.levels[lid],
x = (2 * lid - 1) / (2 * num),
name = trellis.grobname("fg", type = "strip"),
gp = gp.text)
}
else
{
grid.text(label = factor.levels[lid],
y = (2 * lid - 1) / (2 * num),
rot = 90,
name = trellis.grobname("fg", type = "strip.left"),
gp = gp.text)
}
}
}
upViewport()
## border is drawn with clipping off
if (horizontal)
pushViewport(viewport(y = (length(which.panel)-which.given+1-0.5)/length(which.panel),
height = 1/length(which.panel),
clip = "off",
name = paste("strip.default.off", length(which.panel)-which.given+1, sep = ".")))
# pushViewport(viewport(y = (which.given-0.5)/length(which.panel),
# height = 1/length(which.panel),
# clip = "off",
# name = paste("strip.default.off", which.given, sep = ".")))
else
pushViewport(viewport(x = 1 - (length(which.panel)-which.given+1-0.5)/length(which.panel),
width = 1/length(which.panel),
clip = "off",
name = paste("strip.left.default.off", length(which.panel)-which.given+1, sep = ".")))
# pushViewport(viewport(x = 1 - (which.given-0.5)/length(which.panel),
# width = 1/length(which.panel),
# clip = "off",
# name = paste("strip.left.default.off", which.given, sep = ".")))
strip.border <- trellis.par.get("strip.border")
## draw border for strip
if (horizontal)
type <- "strip"
else
type <- "strip.left"
grid.rect(name = trellis.grobname("border", type = type),
gp =
gpar(col = rep(strip.border$col, length.out = which.given)[which.given],
lty = rep(strip.border$lty, length.out = which.given)[which.given],
lwd = rep(strip.border$lwd, length.out = which.given)[which.given],
alpha = rep(strip.border$alpha, length.out = which.given)[which.given],
fill = "transparent"))
upViewport()
}
plot.trellisEx <-
function(x,
position = NULL, split = NULL,
more = FALSE, newpage = TRUE,
packet.panel = packet.panel.default,
draw.in = NULL,
panel.height = lattice.getOption("layout.heights")$panel,
panel.width = lattice.getOption("layout.widths")$panel,
save.object = lattice.getOption("save.object"),
panel.error = lattice.getOption("panel.error"),
prefix = NULL,
...)
{
## make sure we have a device open
# browser()
if (is.null(dev.list())) trellis.device()
else if (is.null(trellis.par.get()))
trellis.device(device = .Device, new = FALSE)
## if necessary, save current settings and apply temporary
## settings in x$par.settings
if (!is.null(x$par.settings))
{
## save current state, restore later
opar <- trellis.par.get() ## get("lattice.theme", envir = .LatticeEnv)
trellis.par.set(theme = x$par.settings)
on.exit(trellis.par.set(opar, strict = 2L), add = TRUE)
}
## do the same for lattice.options
# browser()
if (!is.null(x$lattice.options))
{
## save current state, restore later
oopt <- lattice.options(x$lattice.options)
# oopt <- lattice.options()
# lattice.options(x$lattice.options)
on.exit(lattice.options(oopt), add = TRUE)
}
## We'll also allow arguments to print.trellis (or plot.trellis)
## to be included within a trellis object. Partial matching is
## not done.
if (!is.null(x$plot.args))
{
supplied <- names(x$plot.args)
## Can't think of a clean way, so...
if ("position" %in% supplied && missing(position)) position <- x$plot.args$position
if ("split" %in% supplied && missing(split)) split <- x$plot.args$split
if ("more" %in% supplied && missing(more)) more <- x$plot.args$more
if ("newpage" %in% supplied && missing(newpage)) newpage <- x$plot.args$newpage
if ("packet.panel" %in% supplied && missing(packet.panel)) packet.panel <- x$plot.args$packet.panel
if ("draw.in" %in% supplied && missing(draw.in)) draw.in <- x$plot.args$draw.in
if ("panel.height" %in% supplied && missing(panel.height)) panel.height <- x$plot.args$panel.height
if ("panel.width" %in% supplied && missing(panel.width)) panel.width <- x$plot.args$panel.width
if ("save.object" %in% supplied && missing(save.object)) save.object <- x$plot.args$save.object
if ("panel.error" %in% supplied && missing(panel.error)) panel.error <- x$plot.args$panel.error
if ("prefix" %in% supplied && missing(prefix)) prefix <- x$plot.args$prefix
}
# browser()
panel.error <- lattice:::getFunctionOrName(panel.error)
bg <- trellis.par.get("background")$col
new <- newpage && !lattice:::lattice.getStatus("print.more") && is.null(draw.in)
if (!is.null(draw.in))
{
depth <- downViewport(draw.in)
on.exit(upViewport(depth), add = TRUE)
}
on.exit(lattice:::lattice.setStatus(print.more = more), add = TRUE)
usual <- (is.null(position) && is.null(split))
## This means this plot will be the first one on a new page, so reset counter
if (new) lattice:::lattice.setStatus(plot.index = 0L)
## get default prefix for grid viewport/object names
pindex <- 1L + lattice:::lattice.getStatus("plot.index")
if (is.null(prefix)) prefix <- sprintf("plot_%02g", pindex)
lattice:::lattice.setStatus(plot.index = pindex)
## Set this so that panel and axis functions can use it, but set
## it again before exiting (in case some user action has changed
## it in the meantime) so that further calls to trellis.focus()
## etc. can use it.
lattice:::lattice.setStatus(current.prefix = prefix)
on.exit(lattice:::lattice.setStatus(current.prefix = prefix), add = TRUE)
# browser()
## Initialize list for this prefix
# (lattice:::.LatticeEnv)$lattice.status[[prefix]] <- lattice:::.defaultLatticePrefixStatus()
## Equivalently
## lattice.setStatus(structure(list(.defaultLatticePrefixStatus()),
## names = prefix))
## save the current object, if so requested. This used to be done
## at the end, so that it wouldn't happen if there were errors
## during printing. However, doing this now will allow things
## like trellis.panelArgs() to work in panel/axis functions, which
## I think is a better trade-off.
## FIXME: the problem with this is that if, e.g., the panel
## function calls print.trellis(), then the last object is not
## what one would expect.
if (save.object)
{
lattice:::lattice.setStatus(current.plot.saved = TRUE, prefix = prefix)
## assign("last.object", x, envir = .LatticeEnv)
lattice:::lattice.setStatus(last.object = x, prefix = prefix)
}
else
lattice:::lattice.setStatus(current.plot.saved = FALSE, prefix = prefix)
global.gpar <-
do.call(gpar,
lattice:::updateList(trellis.par.get("grid.pars"),
list(fontsize = trellis.par.get("fontsize")$text)))
if (!is.null(position))
{
stopifnot (length(position) == 4)
if (new)
{
grid.newpage()
grid.rect(name=trellis.grobname("background", type=""),
gp = gpar(fill = bg, col = "transparent"))
}
pushViewport(viewport(x = position[1], y = position[2],
width = position[3] - position[1],
height = position[4] - position[2],
just = c("left","bottom"),
name = trellis.vpname("position", prefix = prefix)))
if (!is.null(split))
{
stopifnot (length(split) == 4)
pushViewport(viewport(layout = grid.layout(nrow = split[4], ncol = split[3]),
name = trellis.vpname("split", prefix = prefix) ))
pushViewport(viewport(layout.pos.row = split[2], layout.pos.col = split[1],
name = trellis.vpname("split.location", prefix = prefix) ))
}
}
else if (!is.null(split))
{
stopifnot(length(split) == 4)
if (new)
{
grid.newpage()
grid.rect(name = trellis.grobname("background", type=""),
gp = gpar(fill = bg, col = "transparent"))
}
pushViewport(viewport(layout = grid.layout(nrow = split[4], ncol = split[3]),
name = trellis.vpname("split", prefix = prefix) ))
pushViewport(viewport(layout.pos.row = split[2], layout.pos.col = split[1],
name = trellis.vpname("split.location", prefix = prefix) ))
}
## order.cond will be a multidimensional array, with
## length(dim(order.cond)) = number of conditioning
## variables. It's a numeric vector 1:(number.of.panels), with
## dim() = c(nlevels(g1), ..., nlevels(gn)), where g1, ..., gn are
## the conditioning variables.
## manipulating order.cond has 2 uses. Using normal indexing, the
## order of plots within a conditioning variable can be altered,
## or only a subset of the levels used. Also, using aperm, the
## order of conditioning can be altered.
## the information required to make the appropriate permutation
## and indexing is in the components index.cond and perm.cond of
## the trellis object
### FIXME: need some thinking here.
## ## Original version (up to 0.13 series):
## order.cond <- seq_len(prod(sapply(x$condlevels, length)))
## dim(order.cond) <- sapply(x$condlevels, length)
## ## first subset, then permute
## order.cond <- do.call("[", c(list(order.cond), x$index.cond, list(drop = FALSE)))
## order.cond <- aperm(order.cond, perm = x$perm.cond)
## ## New version:
## used.condlevels corresponds to the indexed and permuted object.
## These also have to be integer indices rather than character
## labels (necessary for 'packet.panel' computations).
## original.condlevels is required to interpret the results of
## packet.panel and associate them with packets in the original
## object (which are defined in terms of the original levels)
original.condlevels <-
used.condlevels <-
lapply(x$condlevels, function(x) seq_along(x))
used.condlevels <-
mapply("[", used.condlevels, x$index.cond,
MoreArgs = list(drop = FALSE),
SIMPLIFY = FALSE)
used.condlevels <- used.condlevels[x$perm.cond]
inverse.permutation <- order(x$perm.cond) # used later
## an array giving packet numbers corresponding to
## original.condlevels. The idea is to be able to figure out the
## packet given levels of the conditioning variables. The packets
## are naturally thought of as an array. The packet number simply
## counts positions of this array in the standard order
## (i.e. lower dimensions vary faster).
adim <- sapply(original.condlevels, length)
packet.array <- seq_len(prod(adim))
dim(packet.array) <- adim
## FIXME: trying to find a way to make order.cond unnecessary may
## make things simpler, but that's not a very immediate concern
## (and not clear how difficult either).
## order.cond <- seq_len(prod(sapply(x$condlevels, length)))
## dim(order.cond) <- sapply(x$condlevels, length)
## first subset, then permute
## order.cond <- do.call("[", c(list(order.cond), x$index.cond, list(drop = FALSE)))
## order.cond <- aperm(order.cond, perm = x$perm.cond)
## order.cond will be used as indices for (exactly) the following
## 1. panel.args
## 2. x.limits
## 3. y.limits
## may need x$(index|perm).cond later for strip drawing
## cond.max.levels <- dim(order.cond)
cond.max.levels <- sapply(used.condlevels, length)
number.of.cond <- length(cond.max.levels)
panel.layout <-
lattice:::compute.layout(x$layout, cond.max.levels, skip = x$skip)
panel <- lattice:::getFunctionOrName(x$panel) # shall use "panel" in do.call
strip <- lattice:::getFunctionOrName(x$strip)
strip.left <- lattice:::getFunctionOrName(x$strip.left)
axis.line <- trellis.par.get("axis.line")
axis.text <- trellis.par.get("axis.text")
## make sure aspect ratio is preserved for aspect != "fill" but
## this may not always be what's expected. In fact, aspect should
## be "fill" whenever panel.width or panel.height are non-default.
## panel.width <- 1
if (!x$aspect.fill)
panel.height[[1]] <- x$aspect.ratio * panel.width[[1]]
## Evaluate the legend / key grob(s):
legend <- lattice:::evaluate.legend(x$legend)
## legend is now a list of `grob's along with placement info
xaxis.lty <-
if (is.logical(x$x.scales$lty)) axis.line$lty
else x$x.scales$lty
xaxis.lwd <-
if (is.logical(x$x.scales$lwd)) axis.line$lwd
else x$x.scales$lwd
xaxis.col.line <-
if (is.logical(x$x.scales$col.line)) axis.line$col
else x$x.scales$col.line
xaxis.col.text <-
if (is.logical(x$x.scales$col)) axis.text$col
else x$x.scales$col
xaxis.alpha.line <-
if (is.logical(x$x.scales$alpha.line)) axis.line$alpha
else x$x.scales$alpha.line
xaxis.alpha.text <-
if (is.logical(x$x.scales$alpha)) axis.text$alpha
else x$x.scales$alpha
xaxis.font <-
if (is.logical(x$x.scales$font)) axis.text$font
else x$x.scales$font
xaxis.fontface <-
if (is.logical(x$x.scales$fontface)) axis.text$fontface
else x$x.scales$fontface
xaxis.fontfamily <-
if (is.logical(x$x.scales$fontfamily)) axis.text$fontfamily
else x$x.scales$fontfamily
xaxis.lineheight <-
if (is.logical(x$x.scales$lineheight)) axis.text$lineheight
else x$x.scales$lineheight
xaxis.cex <-
if (is.logical(x$x.scales$cex)) rep(axis.text$cex, length.out = 2)
else x$x.scales$cex
xaxis.rot <-
if (is.logical(x$x.scales$rot)) c(0, 0)
else x$x.scales$rot
yaxis.lty <-
if (is.logical(x$y.scales$lty)) axis.line$lty
else x$y.scales$lty
yaxis.lwd <-
if (is.logical(x$y.scales$lwd)) axis.line$lwd
else x$y.scales$lwd
yaxis.col.line <-
if (is.logical(x$y.scales$col.line)) axis.line$col
else x$y.scales$col.line
yaxis.col.text <-
if (is.logical(x$y.scales$col)) axis.text$col
else x$y.scales$col
yaxis.alpha.line <-
if (is.logical(x$y.scales$alpha.line)) axis.line$alpha
else x$y.scales$alpha.line
yaxis.alpha.text <-
if (is.logical(x$y.scales$alpha)) axis.text$alpha
else x$y.scales$alpha
yaxis.font <-
if (is.logical(x$y.scales$font)) axis.text$font
else x$y.scales$font
yaxis.fontface <-
if (is.logical(x$y.scales$fontface)) axis.text$fontface
else x$y.scales$fontface
yaxis.fontfamily <-
if (is.logical(x$y.scales$fontfamily)) axis.text$fontfamily
else x$y.scales$fontfamily
yaxis.lineheight <-
if (is.logical(x$y.scales$lineheight)) axis.text$lineheight
else x$y.scales$lineheight
yaxis.cex <-
if (is.logical(x$y.scales$cex)) rep(axis.text$cex, length.out = 2)
else 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.out = number.of.cond)
strip.col.default.fg <-
rep(trellis.par.get("strip.shingle")$col,
length.out = number.of.cond)
strip.border <-
lapply(trellis.par.get("strip.border"),
function(x) rep(x, length.out = number.of.cond))
## Start layout calculations when only number of panels per page
## is pecified (this refers to the layout argument, not grid
## layouts)
## using device dimensions to calculate default layout:
if (panel.layout[1] == 0)
{
ddim <- par("din")
device.aspect <- ddim[2] / ddim[1]
panel.aspect <- panel.height[[1]] / panel.width[[1]]
plots.per.page <- panel.layout[2]
m <- max (1, round(sqrt(panel.layout[2] * device.aspect / panel.aspect)))
## changes made to fix bug (PR#1744)
n <- ceiling(plots.per.page/m)
m <- ceiling(plots.per.page/n)
panel.layout[1] <- n
panel.layout[2] <- m
}
## End layout calculations
plots.per.page <- panel.layout[1] * panel.layout[2]
cols.per.page <- panel.layout[1]
rows.per.page <- panel.layout[2]
number.of.pages <- panel.layout[3]
lattice:::lattice.setStatus(current.plot.multipage = number.of.pages > 1, prefix = prefix)
## these will also eventually be 'status' variables
current.panel.positions <- matrix(0, rows.per.page, cols.per.page)
current.packet.positions <- matrix(0, rows.per.page, cols.per.page)
current.cond.levels <- vector(mode = "list", length = rows.per.page * cols.per.page)
dim(current.cond.levels) <- c(rows.per.page, cols.per.page)
## ## following now relegated to packet.panel
## skip <- rep(x$skip, length.out = number.of.pages * rows.per.page * cols.per.page)
x.alternating <- rep(x$x.scales$alternating, length.out = cols.per.page)
y.alternating <- rep(x$y.scales$alternating, length.out = rows.per.page)
x.relation.same <- x$x.scales$relation == "same"
y.relation.same <- x$y.scales$relation == "same"
## get lists for main, sub, xlab, ylab
# browser()
main <-
lattice:::grobFromLabelList(lattice:::getLabelList(x$main,
trellis.par.get("par.main.text")),
name = trellis.grobname("main", type=""))
sub <-
lattice:::grobFromLabelList(lattice:::getLabelList(x$sub,
trellis.par.get("par.sub.text")),
name = trellis.grobname("sub", type=""))
xlab <-
lattice:::grobFromLabelList(lattice:::getLabelList(x$xlab,
trellis.par.get("par.xlab.text"),
x$xlab.default),
name = trellis.grobname("xlab", type=""))
ylab <-
lattice:::grobFromLabelList(lattice:::getLabelList(x$ylab,
trellis.par.get("par.ylab.text"),
x$ylab.default),
name = trellis.grobname("ylab", type=""),
orient = 90)
xlab.top <-
lattice:::grobFromLabelList(lattice:::getLabelList(x$xlab.top,
trellis.par.get("par.xlab.text")),
name = trellis.grobname("xlab.top", type=""))
ylab.right <-
lattice:::grobFromLabelList(lattice:::getLabelList(x$ylab.right,
trellis.par.get("par.ylab.text")),
name = trellis.grobname("ylab.right", type=""),
orient = 90)
# groupBy
## get par.strip.text
par.strip.text <- trellis.par.get("add.text")
par.strip.text$lines <- 1
if (!is.null(x$par.strip.text))
par.strip.text[names(x$par.strip.text)] <- x$par.strip.text
## Shall calculate the per page Grid layout now:
## this layout will now be used for each page (this is quite
## complicated and unfortunately very convoluted)
layoutCalculations <-
lattice:::calculateGridLayout(x,
rows.per.page, cols.per.page,
number.of.cond,
panel.height, panel.width,
main, sub,
xlab, ylab, xlab.top, ylab.right,
x.alternating, y.alternating,
x.relation.same, y.relation.same,
xaxis.rot, yaxis.rot,
xaxis.cex, yaxis.cex,
xaxis.lineheight, yaxis.lineheight,
par.strip.text,
legend)
lattice:::lattice.setStatus(layout.details = layoutCalculations, prefix = prefix)
lattice:::lattice.setStatus(as.table = x$as.table, prefix = prefix)
page.layout <- layoutCalculations$page.layout
pos.heights <- layoutCalculations$pos.heights
pos.widths <- layoutCalculations$pos.widths
n.row <- lattice:::layoutNRow(page.layout)
n.col <- lattice:::layoutNCol(page.layout)
## commence actual plotting
cond.current.level <- rep(1, number.of.cond)
## this vector represents the combination of levels of the
## conditioning variables for the current panel. We're changing
## to a new scheme which should make this unnecessary, but we need
## to keep it for now to ensure the first page is drawn (kinda
## stupid, but that part of the code was there to ensure that an
## `empty' trellis object doesn't waste a page. Actually, it
## might be redundant, since in that case number.of.pages should
## be 0. FIXME: Check it out)
panel.counter <- 0
## panel.number is available as an optional argument to the panel
## function (FIXME: to be deprecated). It's a strictly increasing
## sequential counter keeping track of which panel is being drawn.
## This is usually the same as, but can be different from
## packet.number, which is an index to which packet combination is
## being used.
## FIXME: what happens when number of pages is 0?
## message("no of pages: ", number.of.pages)
for (page.number in seq_len(number.of.pages))
{
if (TRUE) ## FIXME: remove this after a few versions and reformat
{
## In older versions, we used to decide here whether a new
## page was actually needed, i.e., whether there is
## anything to draw (o.w., why waste a page?). This is no
## longer possible because we don't know a priori what
## packet.panel() will return.
if (usual)
{
if (new) grid.newpage()
grid.rect(name = trellis.grobname("background", type=""),
gp = gpar(fill = bg, col = "transparent"))
new <- TRUE
}
pushViewport(viewport(layout = page.layout,
gp = global.gpar,
name = trellis.vpname("toplevel", prefix = prefix)))
if (!is.null(main))
{
lattice:::drawInViewport(main,
viewport(layout.pos.row = pos.heights$main,
name= trellis.vpname("main", prefix = prefix)))
}
if (!is.null(sub))
{
lattice:::drawInViewport(sub,
viewport(layout.pos.row = pos.heights$sub,
name= trellis.vpname("sub", prefix = prefix)))
}
if (!is.null(xlab))
{
lattice:::drawInViewport(xlab,
viewport(layout.pos.row = pos.heights$xlab,
layout.pos.col = pos.widths$panel,
name= trellis.vpname("xlab", prefix = prefix)))
}
if (!is.null(ylab))
{
lattice:::drawInViewport(ylab,
viewport(layout.pos.col = pos.widths$ylab,
layout.pos.row = pos.heights$panel,
name= trellis.vpname("ylab", prefix = prefix)))
}
if (!is.null(xlab.top))
{
lattice:::drawInViewport(xlab.top,
viewport(layout.pos.row = pos.heights$xlab.top,
layout.pos.col = pos.widths$panel,
name= trellis.vpname("xlab.top", prefix = prefix)))
}
if (!is.null(ylab.right))
{
lattice:::drawInViewport(ylab.right,
viewport(layout.pos.col = pos.widths$ylab.right,
layout.pos.row = pos.heights$panel,
name= trellis.vpname("ylab.right", prefix = prefix)))
}
last.panel <- prod(sapply(x$index.cond, length))
## Create a viewport encompassing all panels and strips,
## but don't do anything in it. This is useful later for
## trellis.focus() like operations.
rowRange <- with(pos.heights, range(panel, strip, axis.panel))
colRange <- with(pos.widths, range(panel, strip.left, axis.panel))
pushViewport(viewport(layout.pos.row = rowRange,
layout.pos.col = colRange,
clip = "off",
name = trellis.vpname("figure")))
upViewport()
## preliminary loop through possible positions, doing some
## calculations that allow some helpful status variables
## to be set.
## first, initialize status variables
current.panel.positions[, ] <- 0
current.packet.positions[, ] <- 0
current.cond.levels[, ] <- list(NULL)
for (row in seq_len(rows.per.page))
for (column in seq_len(cols.per.page))
{
## levels being used in this panel
which.packet <-
packet.panel(layout = panel.layout,
condlevels = used.condlevels,
page = page.number,
row = row,
column = column,
skip = x$skip)
if (!is.null(which.packet))
{
## permute to restore original order
which.packet <- which.packet[inverse.permutation]
current.cond.levels[[row, column]] <- which.packet
## packet.number should be same as packet.array[which.packet]
## ^^^^^^^^^^^
## (length not fixed)
packet.number <-
do.call("[", c(list(x = packet.array), as.list(which.packet)))
current.packet.positions[row, column] <- packet.number
## packet.number retrieves the appropriate
## entry of panel.args and [xy].limits. It has
## to be this way because otherwise
## non-trivial orderings will not work.
## But we also provide a simple incremental
## counter that may be used as a panel
## function argument
panel.counter <- panel.counter + 1
current.panel.positions[row, column] <- panel.counter
}
}
lattice:::lattice.setStatus(current.cond.levels = current.cond.levels, prefix = prefix)
lattice:::lattice.setStatus(current.panel.positions = current.panel.positions, prefix = prefix)
lattice:::lattice.setStatus(current.packet.positions = current.packet.positions, prefix = prefix)
## loop through positions again, doing the actual drawing
## this time
for (row in seq_len(rows.per.page))
for (column in seq_len(cols.per.page))
{
lattice:::lattice.setStatus(current.focus.row = row,
current.focus.column = column,
prefix = prefix)
which.packet <- which.packet(prefix = prefix)
if (!is.null(which.packet))
{
packet.number <- packet.number(prefix = prefix)
panel.number <- panel.number(prefix = prefix) ## needed? FIXME
## this gives the row position from the bottom
actual.row <- if (x$as.table)
(rows.per.page-row+1) else row
pos.row <- pos.heights$panel[row]
pos.col <- pos.widths$panel[column]
# browser()
xscale.comps <-
if (x.relation.same)
x$xscale.components(lim = x$x.limits,
## (FIXME: needs work) packet.list = ...
top = TRUE,
## rest passed on to
## calculateAxisComponents
## in the default
## case:
at = x$x.scales$at,
used.at = x$x.used.at,
num.limit = x$x.num.limit,
labels = x$x.scales$labels,
logsc = x$x.scales$log,
abbreviate = x$x.scales$abbreviate,
minlength = x$x.scales$minlength,
n = x$x.scales$tick.number,
format.posixt = x$x.scales$format)
else
x$xscale.components(lim = x$x.limits[[packet.number]],
## FIXME: needs work packet.list = ...
top = FALSE,
## rest passed on to
## calculateAxisComponents
## in the default
## case:
at = if (is.list(x$x.scales$at))
x$x.scales$at[[packet.number]]
else x$x.scales$at,
used.at = x$x.used.at[[packet.number]],
num.limit = x$x.num.limit[[packet.number]],
labels =
if (is.list(x$x.scales$labels))
x$x.scales$labels[[packet.number]]
else x$x.scales$labels,
logsc = x$x.scales$log,
abbreviate = x$x.scales$abbreviate,
minlength = x$x.scales$minlength,
n = x$x.scales$tick.number,
format.posixt = x$x.scales$format)
yscale.comps <-
if (y.relation.same)
x$yscale.components(lim = x$y.limits,
## FIXME: needs work packet.list = ...
right = TRUE,
## rest passed on to
## calculateAxisComponents
## in the default
## case:
at = x$y.scales$at,
used.at = x$y.used.at,
num.limit = x$y.num.limit,
labels = x$y.scales$labels,
logsc = x$y.scales$log,
abbreviate = x$y.scales$abbreviate,
minlength = x$y.scales$minlength,
n = x$y.scales$tick.number,
format.posixt = x$y.scales$format)
else
x$yscale.components(lim = x$y.limits[[packet.number]],
## FIXME: needs work packet.list = ...
right = FALSE,
## rest passed on to
## calculateAxisComponents
## in the default
## case:
at = if (is.list(x$y.scales$at))
x$y.scales$at[[packet.number]]
else x$y.scales$at,
used.at = x$y.used.at[[packet.number]],
num.limit = x$y.num.limit[[packet.number]],
labels =
if (is.list(x$y.scales$labels))
x$y.scales$labels[[packet.number]]
else x$y.scales$labels,
logsc = x$y.scales$log,
abbreviate = x$y.scales$abbreviate,
minlength = x$y.scales$minlength,
n = x$y.scales$tick.number,
format.posixt = x$y.scales$format)
xscale <- xscale.comps$num.limit
yscale <- yscale.comps$num.limit
############################################
### drawing panel background ##
############################################
pushViewport(viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col,
xscale = xscale,
yscale = yscale,
clip = trellis.par.get("clip")$panel,
name =
trellis.vpname("panel",
column = column,
row = row,
prefix = prefix,
clip.off = FALSE)))
panel.bg <- trellis.par.get("panel.background")
if (!is.null(panel.bg$col) && (panel.bg$col != "transparent"))
panel.fill(col = panel.bg$col)
upViewport()
############################################
### drawing the axes ##
############################################
### Note: axes should always be drawn before the panel, so that
### background grids etc. can be drawn.
### whether or not axes are drawn, we'll create viewports for them
### anyway, so that users can later interactively add axes/other stuff
### if they wish. First up, we'll have a 'strip.column.row.off'
### viewport for the top axes, then another one for those on the left
### (there can be strips on the left too), and then a
### 'panel.column.row.off' viewport for the other 2 (no strips allowed
### there). The names may seem a bit unintuitive, and perhaps they
### are, but some justification is provided in help(trellis.focus)
pushViewport(viewport(layout.pos.row = pos.row - 1,
layout.pos.col = pos.col,
xscale = xscale,
clip = "off",
name =
trellis.vpname("strip",
column = column,
row = row,
prefix = prefix,
clip.off = TRUE)))
## X-axis above
x$axis(side = "top",
scales = x$x.scales,
components = xscale.comps,
as.table = x$as.table,
rot = xaxis.rot[2],
text.col = xaxis.col.text,
text.alpha = xaxis.alpha.text,
text.cex = xaxis.cex[2],
text.font = xaxis.font,
text.fontfamily = xaxis.fontfamily,
text.fontface = xaxis.fontface,
text.lineheight = xaxis.lineheight,
line.col = xaxis.col.line,
line.lty = xaxis.lty,
line.lwd = xaxis.lwd,
line.alpha = xaxis.alpha.line,
prefix = prefix)
upViewport()
## Y-axis to the left
pushViewport(viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col - 1,
yscale = yscale,
clip = "off",
name =
trellis.vpname("strip.left",
column = column,
row = row,
prefix = prefix,
clip.off = TRUE)))
x$axis(side = "left",
scales = x$y.scales,
components = yscale.comps,
as.table = x$as.table,
rot = yaxis.rot[1],
text.col = yaxis.col.text,
text.alpha = yaxis.alpha.text,
text.cex = yaxis.cex[1],
text.font = yaxis.font,
text.fontfamily = yaxis.fontfamily,
text.fontface = yaxis.fontface,
text.lineheight = yaxis.lineheight,
line.col = yaxis.col.line,
line.lty = yaxis.lty,
line.lwd = yaxis.lwd,
line.alpha = yaxis.alpha.line,
prefix = prefix)
upViewport()
## X-axis bottom and Y-axis right
pushViewport(viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col,
xscale = xscale,
yscale = yscale,
clip = "off",
name =
trellis.vpname("panel",
column = column,
row = row,
prefix = prefix,
clip.off = TRUE)))
## X-axis below
x$axis(side = "bottom",
scales = x$x.scales,
components = xscale.comps,
as.table = x$as.table,
rot = xaxis.rot[1],
text.col = xaxis.col.text,
text.alpha = xaxis.alpha.text,
text.cex = xaxis.cex[1],
text.font = xaxis.font,
text.fontfamily = xaxis.fontfamily,
text.fontface = xaxis.fontface,
text.lineheight = xaxis.lineheight,
line.col = xaxis.col.line,
line.lty = xaxis.lty,
line.lwd = xaxis.lwd,
line.alpha = xaxis.alpha.line,
prefix = prefix)
## Y-axis to the right
x$axis(side = "right",
scales = x$y.scales,
components = yscale.comps,
as.table = x$as.table,
rot = yaxis.rot[2],
text.col = yaxis.col.text,
text.alpha = yaxis.alpha.text,
text.cex = yaxis.cex[2],
text.font = yaxis.font,
text.fontfamily = yaxis.fontfamily,
text.fontface = yaxis.fontface,
text.lineheight = yaxis.lineheight,
line.col = yaxis.col.line,
line.lty = yaxis.lty,
line.lwd = yaxis.lwd,
line.alpha = yaxis.alpha.line,
prefix = prefix)
## N.B.: We'll need this viewport again later
## to draw a border around it. However, this
## must be postponed till after the panel is
## drawn, since otherwise the border is liable
## to be obscured.
upViewport()
############################################
### done drawing axes ##
############################################
#########################################################################
### Draw the box around panels. This used to be done with clipping ##
### on, which caused some subtle and apparently puzzling side effects. ##
#########################################################################
downViewport(trellis.vpname("panel",
column = column,
row = row,
prefix = prefix,
clip.off = TRUE))
grid.rect(name = trellis.grobname("border",
type="panel"),
gp =
gpar(col = axis.line$col,
lty = axis.line$lty,
lwd = axis.line$lwd,
alpha = axis.line$alpha,
fill = "transparent"))
upViewport()
############################################
### drawing the panel ##
############################################
## viewport already created for drawing background
downViewport(trellis.vpname("panel",
column = column,
row = row,
prefix = prefix,
clip.off = FALSE))
## pushViewport(viewport(layout.pos.row = pos.row,
## layout.pos.col = pos.col,
## xscale = xscale,
## yscale = yscale,
## clip = trellis.par.get("clip")$panel,
## name =
## trellis.vpname("panel",
## column = column,
## row = row,
## prefix = prefix,
## clip.off = FALSE)))
pargs <- c(x$panel.args[[packet.number]],
x$panel.args.common) #,
## FIXME: include prefix = prefix? Could be
## important in very rare cases, but let's
## wait till someone actually has a relevant
## use-case.
## if (!("..." %in% names(formals(panel))))
## pargs <- pargs[intersect(names(pargs), names(formals(panel)))]
## if (is.null(panel.error))
## do.call("panel", pargs)
## else
## tryCatch(do.call("panel", pargs),
## error = function(e) panel.error(e))
if (is.null(panel.error))
lattice:::checkArgsAndCall(panel, pargs)
else
tryCatch(lattice:::checkArgsAndCall(panel, pargs),
error = function(e) panel.error(e))
upViewport()
############################################
### finished drawing panel ##
############################################
#########################################
### draw strip(s) on top ###
#########################################
if (!is.logical(strip)) # logical <==> FALSE
{
pushViewport(viewport(layout.pos.row = pos.row - 1,
layout.pos.col = pos.col,
clip = "off", ## was: trellis.par.get("clip")$strip,
name =
trellis.vpname("strip",
column = column,
row = row,
prefix = prefix,
clip.off = FALSE)))
for(i in seq_len(number.of.cond))
{
## Here, by which.given, I mean which
## in the original order, not the
## permuted order
##reversed the orignal order of strip plotting
# browser()
which.given <- x$perm.cond[i]
which.panel <- which.packet
lattice:::lattice.setStatus(current.which.given =
which.given,
current.which.panel =
which.panel,
prefix = prefix)
strip(which.given = which.given,
which.panel = which.panel,
## panel.number = panel.number,
## packet.number = packet.number,
var.name = names(x$condlevels),
factor.levels = as.character(x$condlevels[[x$perm.cond[i]]]),
shingle.intervals = if (is.list(x$condlevels[[x$perm.cond[i]]]))
do.call("rbind", x$condlevels[[x$perm.cond[i]]]) else NULL,
horizontal = TRUE,
bg = strip.col.default.bg[i],
fg = strip.col.default.fg[i],
par.strip.text = par.strip.text)
}
upViewport()
}
#########################################
### draw strip(s) on left ###
#########################################
if (!is.logical(strip.left)) # logical <==> FALSE
{
pushViewport(viewport(layout.pos.row = pos.row,
layout.pos.col = pos.col - 1,
clip = trellis.par.get("clip")$strip,
name =
trellis.vpname("strip.left",
column = column,
row = row,
prefix = prefix,
clip.off = FALSE)))
for(i in seq_len(number.of.cond))
{
## Here, by which.given, I mean which
## in the original packet order, not
## the permuted order
which.given <- x$perm.cond[i]
which.panel <- which.packet
lattice:::lattice.setStatus(current.which.given =
which.given,
current.which.panel =
which.panel,
prefix = prefix)
strip.left(which.given = which.given,
which.panel = which.panel,
## panel.number = panel.number,
## packet.number = packet.number,
var.name = names(x$condlevels),
factor.levels = as.character(x$condlevels[[x$perm.cond[i]]]),
shingle.intervals = if (is.list(x$condlevels[[x$perm.cond[i]]]))
do.call("rbind", x$condlevels[[x$perm.cond[i]]]) else NULL,
horizontal = FALSE,
bg = strip.col.default.bg[i],
fg = strip.col.default.fg[i],
par.strip.text = par.strip.text)
}
upViewport()
}
}
}
## legend / key plotting
if (!is.null(legend))
{
locs <- names(legend)
for (i in seq_along(legend))
{
key.space <- locs[i]
key.gf <- legend[[i]]$obj
switch(key.space,
left =
lattice:::drawInViewport(key.gf,
viewport(layout.pos.col = pos.widths$key.left,
layout.pos.row = range(pos.heights$panel, pos.heights$strip),
name = trellis.vpname("legend", side = "left", prefix = prefix))),
right =
lattice:::drawInViewport(key.gf,
viewport(layout.pos.col = pos.widths$key.right,
layout.pos.row = range(pos.heights$panel, pos.heights$strip),
name = trellis.vpname("legend", side = "right", prefix = prefix))),
top =
lattice:::drawInViewport(key.gf,
viewport(layout.pos.row = pos.heights$key.top,
layout.pos.col = range(pos.widths$panel, pos.widths$strip.left),
name = trellis.vpname("legend", side = "top", prefix = prefix))),
bottom =
lattice:::drawInViewport(key.gf,
viewport(layout.pos.row = pos.heights$key.bottom,
layout.pos.col = range(pos.widths$panel, pos.widths$strip.left),
name = trellis.vpname("legend", side = "bottom", prefix = prefix))),
inside = {
## There are two choices here ---
## either treat the whole figure region
## as the rectangle, or use just the
## region covered by the panels. This
## is user-controllable through
## lattice.options("legend.bbox").
legend.bbox <- lattice.getOption("legend.bbox")
switch(legend.bbox,
full =
pushViewport(viewport(layout.pos.row = c(1, n.row),
layout.pos.col = c(1, n.col),
name = trellis.vpname("legend.region", prefix = prefix))),
panel =
pushViewport(viewport(layout.pos.row = range(pos.heights$panel, pos.heights$strip),
layout.pos.col = range(pos.widths$panel, pos.widths$strip.left),
name = trellis.vpname("legend.region", prefix = prefix))))
key.corner <-
if (is.null(legend[[i]]$corner)) c(0,1)
else legend[[i]]$corner
key.x <-
if (is.null(legend[[i]]$x)) key.corner[1]
else legend[[i]]$x
key.y <-
if (is.null(legend[[i]]$y)) key.corner[2]
else legend[[i]]$y
lattice:::drawInViewport(key.gf,
viewport(x = unit(key.x, "npc") + unit(0.5 - key.corner[1], "grobwidth", list(key.gf)),
y = unit(key.y, "npc") + unit(0.5 - key.corner[2], "grobheight", list(key.gf)),
name = trellis.vpname("legend", side = "inside", prefix = prefix)))
upViewport(1)
})
}
}
pushViewport(viewport(layout.pos.row = c(1, n.row),
layout.pos.col = c(1, n.col),
name = trellis.vpname("page", prefix = prefix)))
if (!is.null(x$page)) x$page(page.number)
upViewport()
upViewport()
}
}
if (!is.null(position))
{
if (!is.null(split))
{
upViewport()
upViewport()
}
upViewport()
}
else if (!is.null(split))
{
upViewport()
upViewport()
}
lattice:::lattice.setStatus(current.focus.row = 0,
current.focus.column = 0,
vp.highlighted = FALSE,
vp.depth = 0, prefix = prefix)
invisible()
}
Try the QUALIFIER 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.