The R Project SVN
R-packages
(root)/trunk/lattice/R/print.trellis.R – Rev 5315
Rev 5264 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
### Copyright (C) 2001-2006 Deepayan Sarkar <Deepayan.Sarkar@R-project.org>###### This file is part of the lattice package for R.### It is made available under the terms of the GNU General Public### License, version 2, or at your option, any later version,### incorporated herein by reference.###### This program is distributed in the hope that it will be### useful, but WITHOUT ANY WARRANTY; without even the implied### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR### PURPOSE. See the GNU General Public License for more### details.###### You should have received a copy of the GNU General Public### License along with this program; if not, write to the Free### Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,### MA 02110-1301, USA## accessors for a grid layouts nrow and ncollayoutNRow <- function(x) x$nrowlayoutNCol <- function(x) x$ncol## other accessors, for during (and sometimes after) plottingcurrent.row <- function() lattice.getStatus("current.focus.row")current.column <- function() lattice.getStatus("current.focus.column")trellis.currentLayout <- function(which = c("packet", "panel")){which <- match.arg(which)switch(which,packet = lattice.getStatus("current.packet.positions"),panel = lattice.getStatus("current.panel.positions"))}panel.number <- function() trellis.currentLayout("panel")[current.row(), current.column()]packet.number <- function() trellis.currentLayout("packet")[current.row(), current.column()]which.packet <- function() lattice.getStatus("current.cond.levels")[[current.row(), current.column()]]## utility to create a full-fledged list describing a label from parts## (used for main, sub, xlab, ylab)getLabelList <- function(label, text.settings, default.label = NULL){if (!is.null(label)){if (inherits(label, "grob")) return(label)ans <-list(label =if (is.characterOrExpression(label)) labelelse if (is.list(label) && (is.null(names(label)) ||names(label)[1] == "")) label[[1]]else default.label,col = text.settings$col, cex = text.settings$cex,fontfamily = text.settings$fontfamily,fontface = text.settings$fontface,font = text.settings$font,alpha = text.settings$alpha,lineheight = text.settings$lineheight)if (is.list(label) && !is.null(names(label))){if (names(label)[1] == "") label <- label[-1]ans[names(label)] <- label}}else ans <- NULLif (is.null(ans$lab) ||(is.character(ans) && ans$lab == "")) ans <- NULLans}drawInViewport <-function(obj, vp){pushViewport(vp)grid.draw(obj)upViewport()}grobFromLabelList <- function(lab, name = "label", orient = 0){if (is.null(lab) || (is.character(lab) && lab == "")) return (NULL)if (inherits(lab, "grob")) return(lab)process.lab <-function(label, rot = orient,x = NULL, y = NULL,just = "centre",hjust = NULL, vjust = NULL,check.overlap = FALSE,font = NULL, fontfamily = NULL, fontface = NULL,...){ans <-list(label = label, rot = rot, x = x, y = y,just = just, hjust = hjust, vjust = vjust,check.overlap = check.overlap)ans$gplist <-gpar(fontfamily = fontfamily,fontface = chooseFace(fontface, font),...)ans}lab <- do.call(process.lab, lab)if (is.null(lab$x))lab$x <-if (orient == 0) ppoints(n = length(lab$label), a = 0.5)else 0.5if (is.null(lab$y))lab$y <-if (orient == 90) ppoints(n = length(lab$label), a = 0.5)else 0.5textGrob(label = lab$label,x = lab$x,y = lab$y,name = name,just = lab$just,hjust = lab$hjust,vjust = lab$vjust,check.overlap = lab$check.overlap,rot = lab$rot,gp = lab$gplist)## gpar(col = lab$col,## fontfamily = lab$fontfamily,## fontface = chooseFace(lab$fontface, lab$font),## lineheight = lab$lineheight,## alpha = lab$alpha,## cex = lab$cex))}evaluate.legend <- function(legend){if (is.null(legend)) return(NULL)for (i in seq_along(legend)){fun <- legend[[i]]$funfun <-if (is.function(fun)) funelse if (is.character(fun)) get(fun)else eval(fun) ## in case fun is a grob (is this OK?)if (is.function(fun)) fun <- do.call("fun", legend[[i]]$args)legend[[i]]$obj <- funlegend[[i]]$args <- NULLlegend[[i]]$fun <- NULL}legend}panel.error <- function(e){grid.text(gettextf("Error using packet %g\n%s",panel.number(),conditionMessage(e)))}## S3 print method for "trellis" objectsprint.trellis <- function(x, ...){printFunction <- lattice.getOption("print.function")if (is.null(printFunction)) printFunction <- plot.trellisprintFunction(x, ...)invisible(x)}## S3 plot method for "trellis" objectsplot.trellis <-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,...){## 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){assign("last.object", x, envir = .LatticeEnv)lattice.setStatus(current.plot.saved = TRUE)}elselattice.setStatus(current.plot.saved = FALSE)## make sure we have a device openif (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.settingsif (!is.null(x$par.settings)){## save current state, restore lateropar <- trellis.par.get() ## get("lattice.theme", envir = .LatticeEnv)trellis.par.set(theme = x$par.settings)on.exit(trellis.par.set(opar, strict = TRUE), add = TRUE)}## do the same for lattice.optionsif (!is.null(x$lattice.options)){## save current state, restore lateroopt <- 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$positionif ("split" %in% supplied && missing(split)) split <- x$plot.args$splitif ("more" %in% supplied && missing(more)) more <- x$plot.args$moreif ("newpage" %in% supplied && missing(newpage)) newpage <- x$plot.args$newpageif ("packet.panel" %in% supplied && missing(packet.panel)) packet.panel <- x$plot.args$packet.panelif ("draw.in" %in% supplied && missing(draw.in)) draw.in <- x$plot.args$draw.inif ("panel.height" %in% supplied && missing(panel.height)) panel.height <- x$plot.args$panel.heightif ("panel.width" %in% supplied && missing(panel.width)) panel.width <- x$plot.args$panel.widthif ("save.object" %in% supplied && missing(save.object)) save.object <- x$plot.args$save.objectif ("panel.error" %in% supplied && missing(panel.error)) panel.error <- x$plot.args$panel.errorif ("prefix" %in% supplied && missing(prefix)) prefix <- x$plot.args$prefix}panel.error <-if (is.function(panel.error)) panel.errorelse if (is.character(panel.error)) get(panel.error)else eval(panel.error)bg <- trellis.par.get("background")$colnew <- newpage && !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.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 pageif (new) lattice.setStatus(plot.index = 1)## get default prefix for grid viewport/object namesif (is.null(prefix))prefix <- paste("plot", lattice.getStatus("plot.index"), sep = "")lattice.setStatus(current.prefix = prefix)lattice.setStatus(plot.index = 1 + lattice.getStatus("plot.index"))global.gpar <-do.call(gpar,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(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(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 <-compute.layout(x$layout, cond.max.levels, skip = x$skip)panel <- # shall use "panel" in do.callif (is.function(x$panel)) x$panelelse if (is.character(x$panel)) get(x$panel)else eval(x$panel)strip <-if (is.function(x$strip)) x$stripelse if (is.character(x$strip)) get(x$strip)else eval(x$strip)strip.left <-if (is.function(x$strip.left)) x$strip.leftelse if (is.character(x$strip.left)) get(x$strip.left)else eval(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 <- 1if (!x$aspect.fill)panel.height[[1]] <- x$aspect.ratio * panel.width[[1]]## Evaluate the legend / key grob(s):legend <- evaluate.legend(x$legend)## legend is now a list of `grob's along with placement infoxaxis.lty <-if (is.logical(x$x.scales$lty)) axis.line$ltyelse x$x.scales$ltyxaxis.lwd <-if (is.logical(x$x.scales$lwd)) axis.line$lwdelse x$x.scales$lwdxaxis.col.line <-if (is.logical(x$x.scales$col.line)) axis.line$colelse x$x.scales$col.linexaxis.col.text <-if (is.logical(x$x.scales$col)) axis.text$colelse x$x.scales$colxaxis.alpha.line <-if (is.logical(x$x.scales$alpha.line)) axis.line$alphaelse x$x.scales$alpha.linexaxis.alpha.text <-if (is.logical(x$x.scales$alpha)) axis.text$alphaelse x$x.scales$alphaxaxis.font <-if (is.logical(x$x.scales$font)) axis.text$fontelse x$x.scales$fontxaxis.fontface <-if (is.logical(x$x.scales$fontface)) axis.text$fontfaceelse x$x.scales$fontfacexaxis.fontfamily <-if (is.logical(x$x.scales$fontfamily)) axis.text$fontfamilyelse x$x.scales$fontfamilyxaxis.cex <-if (is.logical(x$x.scales$cex)) rep(axis.text$cex, length.out = 2)else x$x.scales$cexxaxis.rot <-if (is.logical(x$x.scales$rot)) c(0, 0)else x$x.scales$rotyaxis.lty <-if (is.logical(x$y.scales$lty)) axis.line$ltyelse x$y.scales$ltyyaxis.lwd <-if (is.logical(x$y.scales$lwd)) axis.line$lwdelse x$y.scales$lwdyaxis.col.line <-if (is.logical(x$y.scales$col.line)) axis.line$colelse x$y.scales$col.lineyaxis.col.text <-if (is.logical(x$y.scales$col)) axis.text$colelse x$y.scales$colyaxis.alpha.line <-if (is.logical(x$y.scales$alpha.line)) axis.line$alphaelse x$y.scales$alpha.lineyaxis.alpha.text <-if (is.logical(x$y.scales$alpha)) axis.text$alphaelse x$y.scales$alphayaxis.font <-if (is.logical(x$y.scales$font)) axis.text$fontelse x$y.scales$fontyaxis.fontface <-if (is.logical(x$y.scales$fontface)) axis.text$fontfaceelse x$y.scales$fontfaceyaxis.fontfamily <-if (is.logical(x$y.scales$fontfamily)) axis.text$fontfamilyelse x$y.scales$fontfamilyyaxis.cex <-if (is.logical(x$y.scales$cex)) rep(axis.text$cex, length.out = 2)else x$y.scales$cexyaxis.rot <-if (!is.logical(x$y.scales$rot)) x$y.scales$rotelse 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] <- npanel.layout[2] <- m}## End layout calculationsplots.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.setStatus(current.plot.multipage = number.of.pages > 1)## these will also eventually be 'status' variablescurrent.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, ylabmain <-grobFromLabelList(getLabelList(x$main,trellis.par.get("par.main.text")),name = trellis.grobname("main"))sub <-grobFromLabelList(getLabelList(x$sub,trellis.par.get("par.sub.text")),name = trellis.grobname("sub"))xlab <-grobFromLabelList(getLabelList(x$xlab,trellis.par.get("par.xlab.text"),x$xlab.default),name = trellis.grobname("xlab"))ylab <-grobFromLabelList(getLabelList(x$ylab,trellis.par.get("par.ylab.text"),x$ylab.default),name = trellis.grobname("ylab"), orient = 90)## get par.strip.textpar.strip.text <- trellis.par.get("add.text")par.strip.text$lines <- 1if (!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 <-calculateGridLayout(x,rows.per.page, cols.per.page,number.of.cond,panel.height, panel.width,main, sub,xlab, ylab,x.alternating, y.alternating,x.relation.same, y.relation.same,xaxis.rot, yaxis.rot,xaxis.cex, yaxis.cex,par.strip.text,legend)lattice.setStatus(layout.details = layoutCalculations)lattice.setStatus(as.table = x$as.table)page.layout <- layoutCalculations$page.layoutpos.heights <- layoutCalculations$pos.heightspos.widths <- layoutCalculations$pos.widthsn.row <- layoutNRow(page.layout)n.col <- layoutNCol(page.layout)## commence actual plottingcond.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 (!any(cond.max.levels - which.packet < 0))if (TRUE) ## FIXME: remove this after a few versions and reformat{if (usual){if (new) grid.newpage()grid.rect(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)){drawInViewport(main,viewport(layout.pos.row = pos.heights$main,name= trellis.vpname("main", prefix = prefix)))}if (!is.null(sub)){drawInViewport(sub,viewport(layout.pos.row = pos.heights$sub,name= trellis.vpname("sub", prefix = prefix)))}if (!is.null(xlab)){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)){drawInViewport(ylab,viewport(layout.pos.col = pos.widths$ylab,layout.pos.row = pos.heights$panel,name= trellis.vpname("ylab", 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 variablescurrent.panel.positions[, ] <- 0current.packet.positions[, ] <- 0current.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 panelwhich.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 orderwhich.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 argumentpanel.counter <- panel.counter + 1current.panel.positions[row, column] <- panel.counter}}lattice.setStatus(current.cond.levels = current.cond.levels)lattice.setStatus(current.panel.positions = current.panel.positions)lattice.setStatus(current.packet.positions = current.packet.positions)## loop through positions again, doing the actual drawing## this timefor (row in seq_len(rows.per.page))for (column in seq_len(cols.per.page)){lattice.setStatus(current.focus.row = row,current.focus.column = column)which.packet <- which.packet()if (!is.null(which.packet)){packet.number <- packet.number()panel.number <- panel.number() ## needed? FIXME## this gives the row position from the bottomactual.row <- if (x$as.table)(rows.per.page-row+1) else rowpos.row <- pos.heights$panel[row]pos.col <- pos.widths$panel[column]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$lab,logsc = x$x.scales$log,abbreviate = x$x.scales$abbr,minlength = x$x.scales$minl,n = x$x.scales$tick.number,format.posixt = x$x.scales$format)elsex$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$lab))x$x.scales$lab[[packet.number]]else x$x.scales$lab,logsc = x$x.scales$log,abbreviate = x$x.scales$abbr,minlength = x$x.scales$minl,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$lab,logsc = x$y.scales$log,abbreviate = x$y.scales$abbr,minlength = x$y.scales$minl,n = x$y.scales$tick.number,format.posixt = x$y.scales$format)elsex$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$lab))x$y.scales$lab[[packet.number]]else x$y.scales$lab,logsc = x$y.scales$log,abbreviate = x$y.scales$abbr,minlength = x$y.scales$minl,n = x$y.scales$tick.number,format.posixt = x$y.scales$format)xscale <- xscale.comps$num.limityscale <- yscale.comps$num.limit############################################### drawing the axes ################################################# 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 abovex$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,line.col = xaxis.col.line,line.lty = xaxis.lty,line.lwd = xaxis.lwd,line.alpha = xaxis.alpha.line)upViewport()## Y-axis to the leftpushViewport(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,line.col = yaxis.col.line,line.lty = yaxis.lty,line.lwd = yaxis.lwd,line.alpha = yaxis.alpha.line)upViewport()## X-axis bottom and Y-axis rightpushViewport(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 belowx$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,line.col = xaxis.col.line,line.lty = xaxis.lty,line.lwd = xaxis.lwd,line.alpha = xaxis.alpha.line)## Y-axis to the rightx$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,line.col = yaxis.col.line,line.lty = yaxis.lty,line.lwd = yaxis.lwd,line.alpha = yaxis.alpha.line)## 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 ############################################################################################# drawing the panel ##############################################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) #,## list(packet.number = packet.number,## panel.number = panel.number))############################################# FIXME: remove this at some point ###### ###if (any(c("packet.number", "panel.number") %in% names(formals(panel)))){warning("'packet.number' and 'panel.number' are no longer supplied to the panel function. See ?packet.number")}### #############################################if (!("..." %in% names(formals(panel))))pargs <- pargs[intersect(names(pargs), names(formals(panel)))]if (is.null(panel.error))do.call("panel", pargs)elsetryCatch(do.call("panel", pargs),error = function(e) panel.error(e))upViewport()############################################### finished drawing panel ########################################################################################################################## 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(gp =gpar(col = axis.line$col,lty = axis.line$lty,lwd = axis.line$lwd,alpha = axis.line$alpha,fill = "transparent"))upViewport()############################################ 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 orderstrip(which.given = x$perm.cond[i],which.panel = which.packet,## 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 orderstrip.left(which.given = x$perm.cond[i],which.panel = which.packet,## 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 plottingif (!is.null(legend)){locs <- names(legend)for (i in seq_along(legend)){key.space <- locs[i]key.gf <- legend[[i]]$objswitch(key.space,left =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 =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 =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 =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", side = "inside", 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", side = "inside", prefix = prefix))))key.corner <-if (is.null(legend[[i]]$corner)) c(0,1)else legend[[i]]$cornerkey.x <-if (is.null(legend[[i]]$x)) key.corner[1]else legend[[i]]$xkey.y <-if (is.null(legend[[i]]$y)) key.corner[2]else legend[[i]]$ydrawInViewport(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))))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.setStatus(current.focus.row = 0,current.focus.column = 0,vp.highlighted = FALSE,vp.depth = 0)invisible()}