### 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 ncol

layoutNRow <- function(x) x$nrow
layoutNCol <- function(x) x$ncol

## other accessors, for during (and sometimes after) plotting

current.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)) label
                 else 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 <- NULL
    if (is.null(ans$lab) ||
        (is.character(ans) && ans$lab == "")) ans <- NULL
    ans
}


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.5 
    if (is.null(lab$y))
        lab$y <-
            if (orient == 90) ppoints(n = length(lab$label), a = 0.5)
            else 0.5
    textGrob(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]]$fun
        fun <- 
            if (is.function(fun)) fun 
            else 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 <- fun
        legend[[i]]$args <- NULL
        legend[[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" objects

print.trellis <- function(x, ...)
{
    printFunction <- lattice.getOption("print.function")
    if (is.null(printFunction)) printFunction <- plot.trellis
    printFunction(x, ...)
    invisible(x)
}



## S3 plot method for "trellis" objects

plot.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)
    }
    else
        lattice.setStatus(current.plot.saved = FALSE)


    ## make sure we have a device open

    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 = TRUE), add = TRUE)
    }

    ## do the same for lattice.options

    if (!is.null(x$lattice.options))
    {
        ## save current state, restore later
        oopt <- 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
    }

    panel.error <-
        if (is.function(panel.error)) panel.error 
        else if (is.character(panel.error)) get(panel.error)
        else eval(panel.error)

    bg <- trellis.par.get("background")$col
    new <-  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 page
    if (new) lattice.setStatus(plot.index = 1)

    ## get default prefix for grid viewport/object names
    if (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.call
        if (is.function(x$panel)) x$panel 
        else if (is.character(x$panel)) get(x$panel)
        else eval(x$panel)

    strip <- 
        if (is.function(x$strip)) x$strip 
        else if (is.character(x$strip)) get(x$strip)
        else eval(x$strip)
    strip.left <- 
        if (is.function(x$strip.left)) x$strip.left 
        else 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 <- 1
    if (!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 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.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.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.setStatus(current.plot.multipage = number.of.pages > 1)

    ## 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

    main <-
        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.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 <-
        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.layout
    pos.heights <- layoutCalculations$pos.heights
    pos.widths <- layoutCalculations$pos.widths

    n.row <- layoutNRow(page.layout)
    n.col <- 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 (!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 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.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 time

            for (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 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]

                        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)
                            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$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)
                            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$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.limit
                        yscale <- 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 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,
                               line.col = xaxis.col.line,
                               line.lty = xaxis.lty,
                               line.lwd = xaxis.lwd,
                               line.alpha = xaxis.alpha.line)
                        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,
                               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 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,
                               line.col = xaxis.col.line,
                               line.lty = xaxis.lty,
                               line.lwd = xaxis.lwd,
                               line.alpha = xaxis.alpha.line)
                        ## 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,
                               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)
                        else
                            tryCatch(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 order

                                strip(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 order

                                strip.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 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 = 
                           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]]$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
                               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))))
                               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()
}