.packageName <- "lattice"


### Copyright 2001-2003 Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA






prepanel.default.bwplot <-
    function(x, y, box.ratio,
             horizontal = TRUE,
             origin = NULL, stack = FALSE,
             levels.fos = length(unique(y)), ...)
{

    ## This function needs to work for all high level functions in the
    ## bwplot family, namely bwplot, dotplot, stripplot and
    ## barchart. For all but barchart, this is simply a question of
    ## getting the ranges. For stacked barcharts, things are slightly
    ## complicated.

    if (length(x) && length(y)) {
        
        #if (!is.numeric(x)) x <- as.numeric(x)
        #if (!is.numeric(y)) y <- as.numeric(y)

        temp <- .5  #* box.ratio/(box.ratio+1)
        if (horizontal)
            list(xlim =
                 if (stack)
             {
                 foo1 <- if (any(x > 0)) range( by(x[x>0], y[x>0, drop = TRUE], sum)) else 0
                 foo2 <- if (any(x < 0)) range( by(x[x<0], y[x<0, drop = TRUE], sum)) else 0
                 range(foo1, foo2)
             }
                 else if (is.numeric(x)) range(x[is.finite(x)], origin)
                 else levels(x),
                 ylim =
                 if (is.numeric(y)) range(y[is.finite(y)])
                 else levels(y),
                 ##ylim = c(1-temp, levels.fos + temp),
                 dx = 1,
                 dy = 1)
        else 
            list(xlim = if (is.numeric(x)) range(x[is.finite(x)]) else levels(x),
                 ##xlim = c(1-temp, levels.fos + temp),
                 ylim =
                 if (stack)
             {
                 foo1 <- if (any(y > 0)) range( by(y[y>0], x[y>0], sum)) else 0
                 foo2 <- if (any(y < 0)) range( by(y[y<0], x[y<0], sum)) else 0
                 range(foo1, foo2)
             }
                 else if (is.numeric(y)) range(y[is.finite(y)], origin)
                 else levels(y),
                 dx = 1,
                 dy = 1)
    }
    else list(c(NA, NA),
              c(NA, NA),
              1, 1)
}





panel.barchart <-
    function(x, y, box.ratio = 1,
             horizontal = TRUE,
             origin = NULL, reference = TRUE,
             stack = FALSE,
             groups = NULL, 
             col = if (is.null(groups)) bar.fill$col else
             regions$col,
             ...)
{
    x <- as.numeric(x)
    y <- as.numeric(y)

    bar.fill <- trellis.par.get("bar.fill")
    reference.line <- trellis.par.get("reference.line")


    ## function defined here so that panel.barchart doesn't need to
    ## have a subscript argument (which would make stripplot always
    ## pass the subscripts to the trellis object, which is unnecessary
    ## when groups = NULL)

    groupSub <- function(groups, subscripts, ...)
        groups[subscripts]

    if (horizontal) {

        ## No grouping

        if (is.null(groups)) {
            if (is.null(origin)) {
                origin <- current.viewport()$xscale[1]
                reference <- FALSE
            }
            height <- box.ratio/(1+box.ratio)
        
            if (reference)
                panel.abline(v = origin,
                             col = reference.line$col,
                             lty = reference.line$lty,
                             lwd = reference.line$lwd)
            grid.rect(gp = gpar(fill = col),
                      y = y,
                      x = rep(origin, length(y)),
                      height = rep(height, length(y)),
                      width = x - origin,
                      just = c("left", "centre"),
                      default.units = "native")
        }

        ## grouped, with stacked bars

        else if (stack) {

            if (!is.null(origin) && origin != 0)
                warning("origin forced to 0 for stacked bars")

            groups <- as.numeric(groups)
            vals <- sort(unique(groups))
            nvals <- length(vals)
            groups <- groupSub(groups, ...)

            regions <- trellis.par.get("regions")
            numcol.r <- length(col)
            col <- 
                if (numcol.r <= nvals) rep(col, length = nvals)
                else col[floor(1+(vals-1)*(numcol.r-1)/(nvals-1))]

            height <- box.ratio/(1 + box.ratio)

            if (reference)
                panel.abline(v = origin,
                             col = reference.line$col,
                             lty = reference.line$lty,
                             lwd = reference.line$lwd)

            for (i in unique(y)) {
                ok <- y == i
                ord <- sort.list(groups[ok])
                pos <- x[ok][ord] > 0
                nok <- sum(pos)
                if (nok > 0)
                    grid.rect(gp = gpar(fill = col[groups[ok][ord][pos]]),
                              y = rep(i, nok),
                              x = cumsum(c(0, x[ok][ord][pos][-nok])),
                              height = rep(height, nok),
                              width = x[ok][ord][pos],
                              just = c("left", "centre"),
                              default.units = "native")
                neg <- x[ok][ord] < 0
                nok <- sum(neg)
                if (nok > 0)
                    grid.rect(gp = gpar(fill = col[groups[ok][ord][neg]]),
                              y = rep(i, nok),
                              x = cumsum(c(0, x[ok][ord][neg][-nok])),
                              height = rep(height, nok),
                              width = x[ok][ord][neg],
                              just = c("left", "centre"),
                              default.units = "native")
            }
        }

        ## grouped, with side by side bars

        else {
            if (is.null(origin)) {
                origin <- current.viewport()$xscale[1]
                reference <- FALSE
            }
            groups <- as.numeric(groups)
            vals <- sort(unique(groups))
            nvals <- length(vals)
            groups <- groupSub(groups, ...)

            regions <- trellis.par.get("regions")
            numcol.r <- length(col)
            col <- 
                if (numcol.r <= nvals) rep(col, length = nvals)
                else col[floor(1+(vals-1)*(numcol.r-1)/(nvals-1))]
            
            height <- box.ratio/(1 + nvals * box.ratio)
            if (reference)
                panel.abline(v = origin,
                             col = reference.line$col,
                             lty = reference.line$lty,
                             lwd = reference.line$lwd)
            for (i in unique(y)) {
                ok <- y == i
                nok <- sum(ok)
                grid.rect(gp = gpar(fill = col[groups[ok]]),
                          y = (i + height * (groups[ok] - (nvals + 1)/2)),
                          x = rep(origin, nok), 
                          height = rep(height, nok),
                          width = x[ok] - origin,
                          just = c("left", "centre"),
                          default.units = "native")
            }
        }
    }
    
    ## if not horizontal

    else {
        if (is.null(groups)) {
            if (is.null(origin)) {
                origin <- current.viewport()$yscale[1]
                reference <- FALSE
            }
            width <- box.ratio/(1+box.ratio)
        
            if (reference)
                panel.abline(h = origin,
                             col = reference.line$col,
                             lty = reference.line$lty,
                             lwd = reference.line$lwd)

            grid.rect(gp = gpar(fill = col),
                      x = x,
                      y = rep(origin, length(x)),
                      width = rep(width, length(x)),
                      height = y - origin,
                      just = c("centre", "bottom"),
                      default.units = "native")
        }
        else if (stack) {

            if (!is.null(origin) && origin != 0)
                warning("origin forced to 0 for stacked bars")

            groups <- as.numeric(groups)
            vals <- sort(unique(groups))
            nvals <- length(vals)
            groups <- groupSub(groups, ...)

            regions <- trellis.par.get("regions")
            numcol.r <- length(col)
            col <- 
                if (numcol.r <= nvals) rep(col, length = nvals)
                else col[floor(1+(vals-1)*(numcol.r-1)/(nvals-1))]
            
            width <- box.ratio/(1 + box.ratio)

            if (reference)
                panel.abline(h = origin,
                             col = reference.line$col,
                             lty = reference.line$lty,
                             lwd = reference.line$lwd)

            for (i in unique(x)) {
                ok <- x == i
                ord <- sort.list(groups[ok])
                pos <- y[ok][ord] > 0
                nok <- sum(pos)
                if (nok > 0)
                    grid.rect(gp = gpar(fill = col[groups[ok][ord][pos]]),
                              x = rep(i, nok),
                              y = cumsum(c(0, y[ok][ord][pos][-nok])),
                              width = rep(width, nok),
                              height = y[ok][ord][pos],
                              just = c("centre", "bottom"),
                              default.units = "native")
                neg <- y[ok][ord] < 0
                nok <- sum(neg)
                if (nok > 0)
                    grid.rect(gp = gpar(fill = col[groups[ok][ord][neg]]),
                              x = rep(i, nok),
                              y = cumsum(c(0, y[ok][ord][neg][-nok])),
                              width = rep(width, nok),
                              height = y[ok][ord][neg],
                              just = c("centre", "bottom"),
                              default.units = "native")
            }

            
        }
        else {
            if (is.null(origin)) {
                origin <- current.viewport()$yscale[1]
                reference = FALSE
            }
            groups <- as.numeric(groups)
            vals <- sort(unique(groups))
            nvals <- length(vals)
            groups <- groupSub(groups, ...)

            regions <- trellis.par.get("regions")
            numcol.r <- length(col)
            col <- 
                if (numcol.r <= nvals) rep(col, length = nvals)
                else col[floor(1+(vals-1)*(numcol.r-1)/(nvals-1))]
            
            width <- box.ratio/(1 + nvals * box.ratio)
            if (reference)
                panel.abline(h = origin,
                             col = reference.line$col,
                             lty = reference.line$lty,
                             lwd = reference.line$lwd)
            for (i in unique(x)) {
                ok <- x == i
                nok <- sum(ok)
                grid.rect(gp = gpar(fill = col[groups[ok]]),
                          x = (i + width * (groups[ok] - (nvals + 1)/2)),
                          y = rep(origin, nok), 
                          width = rep(width, nok),
                          height = y[ok] - origin,
                          just = c("centre", "bottom"),
                          default.units = "native")
            }
        }
    }
}




panel.dotplot <-
    function(x, y, horizontal = TRUE,
             pch = if (is.null(groups)) dot.symbol$pch else sup.symbol$pch,
             col = if (is.null(groups)) dot.symbol$col else sup.symbol$col,
             lty = dot.line$lty,
             lwd = dot.line$lwd,
             col.line = dot.line$col,
             levels.fos = NULL,
             groups = NULL,
             ...)
{
    x <- as.numeric(x)
    y <- as.numeric(y)

    dot.line <- trellis.par.get("dot.line")
    dot.symbol <- trellis.par.get("dot.symbol")
    sup.symbol <- trellis.par.get("superpose.symbol")

    if (horizontal) {
        yscale <- current.viewport()$yscale
        if (is.null(levels.fos))
            levels.fos <- floor(yscale[2])-ceiling(yscale[1])+1
        panel.abline(h=1:levels.fos, col=col.line,
                     lty=lty, lwd=lwd)
        if (is.null(groups)) 
            panel.xyplot(x = x, y = y, col = col, pch = pch, ...)
        else
            panel.superpose(x = x, y = y, groups = groups,
                            col = col, pch = pch, ...)
    }
    else {
        xscale <- current.viewport()$xscale
        if (is.null(levels.fos))
            levels.fos <- floor(xscale[2])-ceiling(xscale[1])+1
        panel.abline(v=1:levels.fos, col=col.line,
                     lty=lty, lwd=lwd)
        if (is.null(groups)) 
            panel.xyplot(x = x, y = y, col = col, pch = pch, ...)
        else 
            panel.superpose(x = x, y = y, groups = groups,
                            col = col, pch = pch, ...)
    }
}





panel.stripplot <-
    function(x, y, jitter.data = FALSE, factor = 0.5,
             horizontal = TRUE, groups = NULL, ...)
{
    x <- as.numeric(x)
    y <- as.numeric(y)
    y.jitter  <-
        if (horizontal && jitter.data) jitter(y, factor = factor)
        else y
    x.jitter  <-
        if (!horizontal && jitter.data) jitter(x, factor = factor)
        else x
    if (is.null(groups)) panel.xyplot(x = x.jitter, y = y.jitter, ...)
    else panel.superpose(x = x.jitter, y = y.jitter, groups = groups, ...)
}





panel.bwplot <-
    function(x, y, box.ratio=1, horizontal = TRUE, pch=box.dot$pch,
             col = box.dot$col, cex = box.dot$cex,
             fill = box.rectangle$fill, varwidth = FALSE,
             levels.fos = NULL, coef = 1.5, ...)
{
    
    x <- as.numeric(x)
    y <- as.numeric(y)

    box.dot <- trellis.par.get("box.dot")
    box.rectangle <- trellis.par.get("box.rectangle")
    box.umbrella <- trellis.par.get("box.umbrella")
    plot.symbol <- trellis.par.get("plot.symbol")

    ## In case levels.fos is not given (which should not happen), I'll
    ## be working on the premise that EACH INTEGER in the y-RANGE is a
    ## potential location of a boxplot. 

    if (horizontal) {

        maxn <- max(by(x, y, length)) ## used if varwidth = TRUE

        yscale <- current.viewport()$yscale
        if (is.null(levels.fos)) levels.fos <- floor(yscale[2])-ceiling(yscale[1])+1
        lower <- ceiling(yscale[1])
        height <- box.ratio/(1+box.ratio)
        xscale <- current.viewport()$xscale
        if (levels.fos > 0)
            for (i in 1:levels.fos) {

                yval  <- i
                stats <- boxplot.stats(x[y==yval], coef = coef)
                
                
                if (stats$n>0)
                {
                    push.viewport(viewport(y=unit(yval, "native"),
                                           height = unit((if (varwidth)
                                           sqrt(stats$n/maxn)  else 1) * height, "native"),
                                           xscale = xscale))
                    
                    r.x <- (stats$stats[2]+stats$stats[4])/2
                    r.w <- stats$stats[4]-stats$stats[2]
                    grid.rect(x = unit(r.x, "native"), width = unit(r.w, "native"),
                              gp = gpar(lwd = box.rectangle$lwd,
                              lty = box.rectangle$lty,
                              fill = fill,
                              col = box.rectangle$col))
                
                    grid.lines(x = unit(stats$stats[1:2],"native"),
                               y=unit(c(.5,.5), "npc"),
                               gp = gpar(col = box.umbrella$col,
                               lwd = box.umbrella$lwd,
                               lty = box.umbrella$lty))
                    
                    grid.lines(x = unit(stats$stats[4:5],"native"),
                               y=unit(c(.5,.5), "npc"),
                               gp = gpar(col = box.umbrella$col,
                               lwd = box.umbrella$lwd,
                               lty = box.umbrella$lty))
                    
                    grid.lines(x = unit(rep(stats$stats[1],2),"native"),
                               y=unit(c(0,1), "npc"),
                               gp = gpar(col = box.umbrella$col,
                               lwd = box.umbrella$lwd,
                               lty = box.umbrella$lty))
                    
                    grid.lines(x = unit(rep(stats$stats[5],2),"native"),
                               y=unit(c(0,1), "npc"),
                               gp = gpar(col = box.umbrella$col,
                               lwd = box.umbrella$lwd,
                               lty = box.umbrella$lty))
                    
                    grid.points(x=stats$stats[3], y=.5, pch=pch, 
                                size = unit(cex * 2.5, "mm"),
                                gp = gpar(col = col, cex = cex))
                    
                    if ((l<-length(stats$out))>0)
                        grid.points(x = stats$out, y = rep(.5,l),
                                    size = unit(plot.symbol$cex * 2.5, "mm"),
                                    pch = plot.symbol$pch,
                                    gp = gpar(col = plot.symbol$col,
                                    cex = plot.symbol$cex))
                    
                    pop.viewport()
                
                }
            }
    
    }
    else {

        maxn <- max(by(y, x, length)) ## used if varwidth = TRUE

        xscale <- current.viewport()$xscale
        if (is.null(levels.fos)) levels.fos <- floor(xscale[2])-ceiling(xscale[1])+1
        lower <- ceiling(xscale[1])
        width <- box.ratio/(1+box.ratio)
        yscale <- current.viewport()$yscale
        if (levels.fos > 0)
            for (i in 1:levels.fos) {
                xval  <- i
                stats <- boxplot.stats(y[x==xval], coef = coef)

                if (stats$n>0)
                {
                    push.viewport(viewport(x = unit(xval, "native"),
                                           width = unit((if (varwidth)
                                           sqrt(stats$n/maxn)  else 1) * width, "native"),
                                           yscale = yscale))
                    
                    r.x <- (stats$stats[2]+stats$stats[4])/2
                    r.w <- stats$stats[4]-stats$stats[2]
                    grid.rect(y = unit(r.x, "native"), height = unit(r.w, "native"),
                              gp = gpar(lwd = box.rectangle$lwd,
                              lty = box.rectangle$lty,
                              fill = fill,
                              col = box.rectangle$col))
                
                    grid.lines(y = unit(stats$stats[1:2],"native"),
                               x = unit(c(.5,.5), "npc"),
                               gp = gpar(col = box.umbrella$col,
                               lwd = box.umbrella$lwd,
                               lty = box.umbrella$lty))
                    
                    grid.lines(y = unit(stats$stats[4:5],"native"),
                               x = unit(c(.5,.5), "npc"),
                               gp = gpar(col = box.umbrella$col,
                               lwd = box.umbrella$lwd,
                               lty = box.umbrella$lty))
                    
                    grid.lines(y = unit(rep(stats$stats[1],2),"native"),
                               x = unit(c(0,1), "npc"),
                               gp = gpar(col = box.umbrella$col,
                               lwd = box.umbrella$lwd,
                               lty = box.umbrella$lty))
                    
                    grid.lines(y = unit(rep(stats$stats[5],2),"native"),
                               x = unit(c(0,1), "npc"),
                               gp = gpar(col = box.umbrella$col,
                               lwd = box.umbrella$lwd,
                               lty = box.umbrella$lty))
                    
                    grid.points(y = stats$stats[3], x = .5, pch = pch, 
                                size = unit(cex * 2.5, "mm"),
                                gp = gpar(col = col, cex = cex))
                    
                    if ((l<-length(stats$out))>0)
                        grid.points(y = stats$out, x = rep(.5,l),
                                    size = unit(plot.symbol$cex * 2.5, "mm"),
                                    pch = plot.symbol$pch,
                                    gp = gpar(col = plot.symbol$col,
                                    cex = plot.symbol$cex))
                    
                    pop.viewport()
                
                }
            }
    
    }
}

# The following needs to work:

# k <- 10# (optional)
# fubar <- function() {
#     k <- -1
#     data = list(x=1:10)
#     names(data$x) <- 1:10
#     barchart(x^k, data)
# }
# fubar()



dotplot <-
    function(formula,
             data = parent.frame(),
             panel = "panel.dotplot",
             groups = NULL,
             ...,
             subset = TRUE)
{

    ## m <- match.call(expand.dots = FALSE)
    ## lapply(dots, eval, data, parent.frame())))

    dots <- list(...)
    groups <- eval(substitute(groups), data, parent.frame())
    subset <- eval(substitute(subset), data, parent.frame())

    try(formula <- eval(formula), silent = TRUE)
    foo <- substitute(formula)
    if (!(is.call(foo) && foo[[1]] == "~")) {
        formula <- as.formula(paste("~", deparse(foo)))
        environment(formula) <- parent.frame()
    }
    call.list <- c(list(formula = formula, data = data,
                        groups = groups,
                        subset = subset,
                        panel = panel,
                        box.ratio = 0),
                   dots)
    do.call("bwplot", call.list)
}



barchart <-
    function(formula,
             data = parent.frame(),
             panel = "panel.barchart",
             box.ratio = 2,
             groups = NULL,
             ...,
             subset = TRUE)
{

    dots <- list(...)
    groups <- eval(substitute(groups), data, parent.frame())
    subset <- eval(substitute(subset), data, parent.frame())

    foo <- substitute(formula)
    if (!(is.call(foo) && foo[[1]] == "~")) {
        formula <- as.formula(paste("~", deparse(foo)))
        environment(formula) <- parent.frame()
    }
    call.list <- c(list(formula = formula, data = data,
                        groups = groups,
                        subset = subset,
                        panel = panel,
                        box.ratio = box.ratio),
                   dots)
    do.call("bwplot", call.list)

}


stripplot <-
    function(formula,
             data = parent.frame(),
             panel = "panel.stripplot",
             jitter = FALSE,
             factor = .5,
             box.ratio = if (jitter) 1 else 0,
             groups = NULL,
             ...,
             subset = TRUE)
{

    dots <- list(...)
    groups <- eval(substitute(groups), data, parent.frame())
    subset <- eval(substitute(subset), data, parent.frame())

    foo <- substitute(formula)
    if (!(is.call(foo) && foo[[1]] == "~")) {
        formula <- as.formula(paste("~", deparse(foo)))
        environment(formula) <- parent.frame()
    }
    call.list <- c(list(formula = formula, data = data,
                        panel = panel,
                        jitter = jitter,
                        factor = factor,
                        groups = groups,
                        subset = subset,
                        box.ratio = box.ratio),
                   dots)

    do.call("bwplot", call.list)

}


bwplot <-
    function(formula,
             data = parent.frame(),
             allow.multiple = FALSE,
             outer = FALSE,
             auto.key = FALSE,
             aspect = "fill",
             layout = NULL,
             panel = "panel.bwplot",
             prepanel = NULL,
             scales = list(),
             strip = TRUE,
             groups = NULL,
             xlab,
             xlim,
             ylab,
             ylim,
             box.ratio = 1,
             horizontal = NULL,
             ...,
             subscripts = !is.null(groups),
             subset = TRUE)
{

    ##m <- match.call(expand.dots = FALSE)
    ##dots <- m$...
    ##dots <- lapply(dots, eval, data, parent.frame())

    dots <- list(...)

    groups <- eval(substitute(groups), data, parent.frame())
    subset <- eval(substitute(subset), data, parent.frame())

    ## Step 1: Evaluate x, y, etc. and do some preprocessing

    formname <- deparse(substitute(formula))
    formula <- eval(substitute(formula), data, parent.frame())

    if (!inherits(formula, "formula"))
        formula <- as.formula(paste("~", formname))
    
    form <-
        latticeParseFormula(formula, data, subset = subset,
                            groups = groups, multiple = allow.multiple,
                            outer = outer, subscripts = TRUE)


    groups <- form$groups

    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)

    if ("subscripts" %in% names(formals(panel))) subscripts <- TRUE
    if (subscripts) subscr <- form$subscr

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

    cond <- form$condition
    number.of.cond <- length(cond)
    x <- form$right
    y <- form$left
    if (is.null(y))
        y <- rep(if (is.null(names(x))) '' else names(x), length = length(x))
    if (number.of.cond == 0) {
        strip <- FALSE
        cond <- list(as.factor(rep(1, length(x))))
        layout <- c(1,1,1)
        number.of.cond <- 1
    }


    if (is.null(horizontal)) {
        horizontal <-
            if ((is.factor(x) || is.shingle(x)) && is.numeric(y)) FALSE
            else TRUE
    }


    if (horizontal) {
        if (!(is.numeric(x))) {
            warning("x should be numeric")
        }
        y <- as.factorOrShingle(y)
        is.f.y <- is.factor(y)  # used throughout the rest of the code
        num.l.y <- nlevels(y)

        if (missing(xlab)) xlab <- form$right.name
        if (missing(ylab)) ylab <- if (is.f.y) NULL else form$left.name
    }
    else {
        if (!(is.numeric(y))) {
            warning("y should be numeric")
        }
        x <- as.factorOrShingle(x)
        is.f.x <- is.factor(x)  # used throughout the rest of the code
        num.l.x <- nlevels(x)

        if (missing(ylab)) ylab <- form$left.name
        if (missing(xlab)) xlab <- if (is.f.x) NULL else form$right.name
    }

    ## create a skeleton trellis object with the
    ## less complicated components:

    foo <- do.call("trellis.skeleton",
                   c(list(aspect = aspect,
                          strip = strip,
                          panel = panel,
                          xlab = xlab,
                          ylab = ylab), dots))

    dots <- foo$dots # arguments not processed by trellis.skeleton
    foo <- foo$foo
    foo$call <- match.call()
    foo$fontsize.normal <- 10
    foo$fontsize.small <- 8

    ## This is for cases like xlab/ylab = list(cex=2)
    if (is.list(foo$xlab) && !is.characterOrExpression(foo$xlab$label))
        foo$xlab$label <- form$right.name
    if (is.list(foo$ylab) && !is.characterOrExpression(foo$ylab$label))
        foo$ylab$label <- form$left.name

    ## Step 2: Compute scales.common (leaving out limits for now)

    ##scales <- 
    ##if (missing(scales)) scales 
    ##else eval(m$scales, data, parent.frame())


    ## The following is to make the default alternating FALSE for factors
    if (is.character(scales)) scales <- list(relation = scales)
    if (is.null(scales$alternating)) {
        if (horizontal) {
            if (is.null(scales$y)) scales$y <- list(alternating = FALSE)
            else if (is.null(scales$y$alternating)) scales$y$alternating <- FALSE
        ## bug if y="free" ? but who cares
        }
        else {
            if (is.null(scales$x)) scales$x <- list(alternating = FALSE)
            else if (is.null(scales$x$alternating)) scales$x$alternating <- FALSE
        ## bug if x="free" ? but who cares
        }
    }
    foo <- c(foo,
             do.call("construct.scales", scales))

    ## Step 3: Decide if limits were specified in call:

    have.xlim <- !missing(xlim)
    if (!is.null(foo$x.scales$limit)) {
        have.xlim <- TRUE
        xlim <- foo$x.scales$limit
    }
    have.ylim <- !missing(ylim)
    if (!is.null(foo$y.scales$limit)) {
        have.ylim <- TRUE
        ylim <- foo$y.scales$limit
    }

    ## Step 4: Decide if log scales are being used:

    have.xlog <- !is.logical(foo$x.scales$log) || foo$x.scales$log
    have.ylog <- !is.logical(foo$y.scales$log) || foo$y.scales$log
    if (have.xlog) {
        xlog <- foo$x.scales$log
        xbase <-
            if (is.logical(xlog)) 10
            else if (is.numeric(xlog)) xlog
            else if (xlog == "e") exp(1)

        x <- log(x, xbase)
        if (have.xlim) xlim <- log(xlim, xbase)
    }
    if (have.ylog) {
        ## warning("Are you sure you want log scale for y ?")
        ylog <- foo$y.scales$log
        ybase <-
            if (is.logical(ylog)) 10
            else if (is.numeric(ylog)) ylog
            else if (ylog == "e") exp(1)

        y <- log(y, ybase)
        if (have.ylim) ylim <- log(ylim, ybase)
    }
    
    ## Step 5: Process cond

    cond.max.level <- unlist(lapply(cond, nlevels))


    id.na <- is.na(x)|is.na(y)
    for (var in cond)
        id.na <- id.na | is.na(var)
    if (!any(!id.na)) stop("nothing to draw")
    ## Nothing simpler ?

    foo$condlevels <- lapply(cond, levels)

    ## Step 6: Evaluate layout, panel.args.common and panel.args

    foo$panel.args.common <- dots
    foo$panel.args.common$box.ratio <- box.ratio
    foo$panel.args.common$horizontal <- horizontal
    foo$panel.args.common$levels.fos <- ## fos - the factor/shingle in x/y
        if (horizontal) num.l.y else num.l.x
    if (subscripts) foo$panel.args.common$groups <- groups

    layout <- compute.layout(layout, cond.max.level, skip = foo$skip)
    plots.per.page <- max(layout[1] * layout[2], layout[2])
    number.of.pages <- layout[3]
    foo$skip <- rep(foo$skip, length = plots.per.page)
    foo$layout <- layout
    nplots <- plots.per.page * number.of.pages

    foo$panel.args <- as.list(1:nplots)
    cond.current.level <- rep(1,number.of.cond)
    panel.number <- 1 # this is a counter for panel number
    for (page.number in 1:number.of.pages)
        if (!any(cond.max.level-cond.current.level<0))
            for (plot in 1:plots.per.page) {

                if (foo$skip[plot]) foo$panel.args[[panel.number]] <- FALSE
                else if(!any(cond.max.level-cond.current.level<0)) {

                    id <- !id.na
                    for(i in 1:number.of.cond)
                    {
                        var <- cond[[i]]
                        id <- id &
                        if (is.shingle(var))
                            ((var >=
                              levels(var)[[cond.current.level[i]]][1])
                             & (var <=
                                levels(var)[[cond.current.level[i]]][2]))
                        else (as.numeric(var) == cond.current.level[i])
                    }

                    if (horizontal) {
                        if (is.f.y) {
                            foo$panel.args[[panel.number]] <-
                                list(x = x[id],
                                     ##y = as.numeric(y[id]))
                                     y = y[id])
                            if (subscripts)
                                foo$panel.args[[panel.number]]$subscripts <-
                                    subscr[id]
                        }
                        else {  # shingle
                            panel.x <- numeric(0)
                            panel.y <- numeric(0)
                            if (subscripts) panel.subscr <- numeric(0)
                            for (k in 1:num.l.y) {
                                tid <- id & (y >= levels(y)[[k]][1]) & (y <= levels(y)[[k]][2])
                                panel.x <- c(panel.x, x[tid])
                                panel.y <- c(panel.y, rep(k,length(tid[tid])))
                                if (subscripts) panel.subscr <- c(panel.subscr, subscr[tid])
                            }
                            foo$panel.args[[panel.number]] <-
                                list(x = panel.x,
                                     y = panel.y)
                            if (subscripts)
                                foo$panel.args[[panel.number]]$subscripts <-
                                    panel.subscr

                        }
                    }
                    else {
                        if (is.f.x) {
                            foo$panel.args[[panel.number]] <-
                                ##list(x = as.numeric(x[id]),
                                list(x = x[id],
                                     y = y[id])
                            if (subscripts)
                                foo$panel.args[[panel.number]]$subscripts <-
                                    subscr[id]
                        }
                        else {  # shingle
                            panel.x <- numeric(0)
                            panel.y <- numeric(0)
                            if (subscripts) panel.subscr <- numeric(0)
                            for (k in 1:num.l.x) {
                                tid <- id & (x >= levels(x)[[k]][1]) & (x <= levels(x)[[k]][2])
                                panel.y <- c(panel.y, y[tid])
                                panel.x <- c(panel.x, rep(k,length(tid[tid])))
                                if (subscripts) panel.subscr <- c(panel.subscr, subscr[tid])
                            }
                            foo$panel.args[[panel.number]] <-
                                list(x = panel.x,
                                     y = panel.y)
                            if (subscripts)
                                foo$panel.args[[panel.number]]$subscripts <-
                                    panel.subscr
                        }
                    }

                    cond.current.level <-
                        cupdate(cond.current.level,
                                cond.max.level)
                }

                panel.number <- panel.number + 1
            }

    foo <- c(foo,
             limits.and.aspect(prepanel.default.bwplot,
                               prepanel = prepanel, 
                               have.xlim = have.xlim, xlim = xlim, 
                               have.ylim = have.ylim, ylim = ylim, 
                               x.relation = foo$x.scales$relation,
                               y.relation = foo$y.scales$relation,
                               panel.args.common = foo$panel.args.common,
                               panel.args = foo$panel.args,
                               aspect = aspect,
                               nplots = nplots,
                               x.axs = foo$x.scales$axs,
                               y.axs = foo$y.scales$axs))


    if (is.null(foo$key) && !is.null(groups) &&
        (is.list(auto.key) || (is.logical(auto.key) && auto.key)))
        foo$key <- do.call("simpleKey",
                           c(list(levels(as.factor(groups))),
                             if (is.list(auto.key)) auto.key else list()))

    class(foo) <- "trellis"
    foo
}






### Copyright 2001-2002  Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA








## Plan: to make things more modular than they are now. As a first
## step, get a function that does a 3d transformation. Probably a good
## idea to do things in terms of homogeneous coordinates


ltransform3dMatrix <- function(screen, R.mat = diag(4)) {

    rot.mat <- diag(3)
    screen.names <- names(screen)
    screen <- lapply(screen, "*", pi/180)

    for(i in seq(along=screen.names)) {
        th <- screen[[i]]
        cth <- cos(th)
        sth <- sin(th)
        tmp.mat <- 
            (if (screen.names[i]=="x")
             matrix(c(1, 0, 0, 0, cth, sth, 0, -sth, cth), 3, 3)
            else if (screen.names[i]=="y")
             matrix(c(cth, 0, -sth, 0, 1, 0, sth, 0, cth), 3, 3)
            else if (screen.names[i]=="z")
             matrix(c(cth, sth, 0, -sth, cth, 0, 0, 0, 1), 3, 3))
        rot.mat <- tmp.mat %*% rot.mat
    }
    rot.mat <- cbind(rot.mat, c(0,0,0))
    rot.mat <- rbind(rot.mat, c(0,0,0,1))
    if (!missing(R.mat)) rot.mat <- rot.mat %*% R.mat
    rot.mat
}





ltransform3dto3d <- function(x, R.mat, za = 1 , zb = 0, zmin, zmax, dist) {
    tdata <- R.mat %*% rbind(x, 1)
    tdata[1,] <- tdata[1,]/tdata[4,]
    tdata[2,] <- tdata[2,]/tdata[4,]
    tdata[3,] <- tdata[3,]/tdata[4,]
    if (!missing(za) && !missing(zb)) {
        #print(zmin)
        #print(zmax)
        #print(dist)

        tdata[4,] <- tdata[3,] ## dummy, so that changes is tdata[3,]
        ## do not affect subsequent calculations of tdata[1:2,]

        if (dist != 0)
        {
            perp.dist.sq <- tdata[1,]^2 + tdata[2,]^2
            orig.v2z <- (zmax-zmin)/dist + zmin - tdata[3,]
            new.v2z <- sqrt(perp.dist.sq + orig.v2z^2)
            tdata[3,] <- tdata[3,] - new.v2z + orig.v2z
        }

        tdata[1,] <- (za + zb * tdata[4,]) * tdata[1,]
        tdata[2,] <- (za + zb * tdata[4,]) * tdata[2,]

    }
    tdata[1:3, ]
}







prepanel.default.cloud <-
    function(distance, xlim, ylim, zlim, zoom = 1,
             rot.mat = rot.mat, aspect = aspect, ...)
{
    aspect <- rep(aspect, length=2)
    corners <-
        rbind(x = c(-1,1,1,-1,-1,1,1,-1) / 2,
              y = c(-1,-1,-1,-1,1,1,1,1) / 2 * aspect[1],
              z = c(-1,-1,1,1,-1,-1,1,1) / 2 * aspect[2])
    corners <- ltransform3dto3d(corners, rot.mat)
    zback <- min(corners[3,])
    zfront <- max(corners[3,])
    za <- (zfront * (1-distance) - zback) / (zfront - zback)
    zb <- distance / (zfront - zback)
    corners[1,] <- (za + zb * corners[3,]) * corners[1,]
    corners[2,] <- (za + zb * corners[3,]) * corners[2,]
    xrng <- range(corners[1,])
    yrng <- range(corners[2,])
    slicelen <- max(diff(xrng), diff(yrng))
    list(xlim = extend.limits(xrng, length = slicelen) / zoom,
         ylim = extend.limits(yrng, length = slicelen) / zoom,
         dx = 1, dy = 1)
}



            

panel.3dscatter.old <-
    function(x, y, z, rot.mat = diag(4), za, zb,  zback,
             zfront, distance, groups = NULL,
             subpanel = if (is.null(groups)) "panel.xyplot"
             else "panel.superpose",
             ...)
{
    subpanel <-
        if (is.character(subpanel)) get(subpanel)
        else eval(subpanel)
    m <- ltransform3dto3d(rbind(x, y, z), rot.mat, za, zb,  zback, zfront, distance)
    subpanel(x = m[1,], y = m[2,], groups = groups, ...)
}



panel.3dscatter <-
    function(x, y, z, rot.mat = diag(4), za, zb,
             zback, zfront, distance,
             zlim, zero,
             groups = NULL, subscripts = TRUE,
             type = 'p',
             col,
             ## eventually make all these cloud.3d$col etc
             col.point = if (is.null(groups)) plot.symbol$col else superpose.symbol$col,
             col.line = if (is.null(groups)) plot.line$col else superpose.line$col,
             lty = if (is.null(groups)) plot.line$lty else superpose.line$lty,
             lwd = if (is.null(groups)) plot.line$lwd else superpose.line$lwd,
             cex = if (is.null(groups)) plot.symbol$cex else superpose.symbol$cex,
             pch = if (is.null(groups)) plot.symbol$pch else superpose.symbol$pch,
             ...)
{
    ##cloud.3d <- list(col=1, cex=1, lty=1, lwd=1, pch=1)
    plot.symbol <- trellis.par.get("plot.symbol")
    plot.line <- trellis.par.get("plot.line")
    superpose.symbol <- trellis.par.get("superpose.symbol")
    superpose.line <- trellis.par.get("superpose.line")
    if (!missing(col)) {
        col.point <- col
        col.lines <- col
    }
    n <- length(x)
    if (n > 0)
    {
        if (is.null(groups))
        {
            col.point <- rep(col.point, length = n)
            col.line <- rep(col.line, length = n)
            lty <- rep(lty, length = n)
            lwd <- rep(lwd, length = n)
            cex <- rep(cex, length = n)
            pch <- rep(pch, length = n)
        }
        else {
            groups <- as.numeric(groups[subscripts])
            nvals <- length(unique(groups))
            col.point <- rep(col.point, length = nvals)[groups]
            col.line <- rep(col.line, length = nvals)[groups]
            lty <- rep(lty, length = nvals)[groups]
            lwd <- rep(lwd, length = nvals)[groups]
            cex <- rep(cex, length = nvals)[groups]
            pch <- rep(pch, length = nvals)[groups]
        }
        m <- ltransform3dto3d(rbind(x, y, z), rot.mat, za, zb, zback, zfront, distance)
        ord <- sort.list(m[3,])
        if (type == 'p')
            lpoints(x = m[1,ord], y = m[2,ord],
                    col = col.point[ord],
                    pch = pch[ord],
                    cex = cex[ord])
        ##cex = cex[ord] * (za + zb * m[3,ord])) - doesn't seem to work
        else if (type == 'h') {
            zero <-
                if (zero < zlim[1]) zlim[1]
                else if (zero > zlim[2]) zlim[2]
                else zero
            ##print(zero)
            other.end <- ltransform3dto3d(rbind(x, y, zero), rot.mat, za, zb, zback, zfront, distance)
            lsegments(m[1,ord], m[2,ord],
                      other.end[1,ord], other.end[2,ord],
                      col = col.line[ord],
                      lty = lty[ord],
                      lwd = lwd[ord])
        }
        else {
            warning(paste("type =", type, "not implemented, consider using 'panel.3d.cloud = panel.3dscatter.old'"))
        }
    }
}




####################################################################
##          Interface to New Experimental C code                  ##
####################################################################



palette.shade <- function(cosangle, height, saturation = .3, ...) {
    hsv(h = height,
        s = saturation,
        v = cosangle)
}



panel.3dwire <- 
    function(x, y, z, rot.mat = diag(4), za, zb,
             minz = 0, maxz = 1,
             col.at, col.regions,
             shade = FALSE,
             shade.colors = palette.shade,
             light.source = c(1, 0, 0),
             col = "black",
             col.groups = superpose.line$col,
             ...)
{
    
    ## x, y, z are in a special form here (compared to most other
    ## places in lattice). x and y are short ascending, describing the
    ## grid, and z is the corresponding z values in the order (x1,y1),
    ## (x1,y2), ... . length(z) == length(x) * length(y). Sometimes, z
    ## might be a matrix, which indicates multiple surfaces. Above
    ## description true for each column in that case.

    lenz <- maxz - minz
    ngroups <- if (is.matrix(z)) ncol(z) else 1
    superpose.line <- trellis.par.get("superpose.line")
    col.groups <- rep(col.groups, ngroups)
    light.source <- light.source/sqrt(sum(light.source * light.source))

    shade.colors <-
        if (is.character(shade.colors)) get(shade.colors)
        else eval(shade.colors)
    
    wirePolygon <-
        if (shade)
            function(xx, yy, misc) {
                ## xx, yy : coordinates of quadrilateral
                grid.polygon(x = xx, y = yy,
                             default.units = "native",
                             gp =
                             gpar(fill = 
                                  shade.colors(misc[1],
                                               (misc[2] - minz)/lenz), 
                                  col = "transparent"))
            }
        else if (length(col.regions) > 1)
            function(xx, yy, misc) {
                grid.polygon(x = xx, y = yy,
                             default.units = "native",
                             gp =
                             gpar(fill =
                                  col.regions[(seq(along = col.at)[col.at > misc[2]])[1] - 1 ],
                                  col = col))
            }
        else if (ngroups == 1)
            function(xx, yy, misc) {
                grid.polygon(x = xx, y = yy,
                             default.units = "native",
                             gp =
                             gpar(fill = col.regions[1],
                                  col = col))
            }
        else
            function(xx, yy, misc) {
                grid.polygon(x = xx, y = yy,
                             default.units = "native",
                             gp =
                             gpar(fill = col.groups[1 + as.integer(misc[3])],
                                  col = col))

            }


    #print(x)
    #print(y)
    #print(z)

    
    .Call("wireframePanelCalculations",
          as.double(x),
          as.double(y),
          as.double(z),
          as.double(rot.mat),
          as.double(za),
          as.double(zb),
          length(x),
          length(y),
          as.integer(ngroups),
          as.double(light.source),
          environment(),
          PACKAGE="lattice")
          
}
      





# panel.3dwire.old <- 
#     function(x, y, z, rot.mat = diag(4), za, zb, zcol,
#              ...)
# {

#     ## x, y, z are in a special form here (compared to most other
#     ## places in lattice). x and y are short ascending, describing the
#     ## grid, and z is the corresponding z values in the order (x1,y1),
#     ## (x1,y2), ... . length(z) == length(x) * length(y). Sometimes, z
#     ## might be a matrix, which indicates multiple surfaces. Above
#     ## description true for each column in that case.

#     grid <- rbind(t(as.matrix(expand.grid(yy = y, xx = x)))[2:1,], z)
#     grid <- ltransform3dto3d(grid, rot.mat, za, zb)

#     nx <- length(x)
#     ny <- length(y)

#     ordvec <- (1: ((nx -1 ) * ny)  )[- (1:(nx - 1)) * ny]
#     ordvec <- ordvec[order(pmax(grid[3, ordvec],
#                                 grid[3, ordvec + ny],
#                                 grid[3, ordvec + ny + 1],
#                                 grid[3, ordvec + 1] ))]
    
#     ##zcol <- zcol[id0][ord]

#     for (i in ordvec)
#         grid.polygon(x = grid[1, c(i, i + ny, i + ny + 1, i + 1)],
#                      y = grid[2, c(i, i + ny, i + ny + 1, i + 1)],
#                      default.units = "native",
#                      gp = gpar(fill = "white", col = "black"))
# }
      







panel.cloud <-
    function(x, y, z, subscripts,
             groups = NULL,
             distance, xlim, ylim, zlim,
             panel.3d.cloud = "panel.3dscatter",
             panel.3d.wireframe = "panel.3dwire",
             rot.mat, aspect,
             par.box = NULL,
             ## next few arguments are an attempt to support
             ## scales. The main problem with scales is that it is
             ## difficult to figure out the best way to place the
             ## scales. Here, they would need to be specified
             ## explicitly. Maybe this code can be used later for a
             ## proper implementation
             xlab, ylab, zlab, scales.3d,
             proportion = 0.6, wireframe = FALSE,
             scpos,
             ...,
             col.at,
             col.regions)
{
    x <- as.numeric(x)
    y <- as.numeric(y)
    z <- as.numeric(z)

    if (any(subscripts)) { ## otherwise nothing to draw (not even box ?)

        par.box.final <- trellis.par.get("box.3d")
        if (!is.null(par.box)) par.box.final[names(par.box)] <- par.box

        aspect <- rep(aspect, length=2)

        x <- x[subscripts]
        y <- y[subscripts]
        z <- z[subscripts]
              
        corners <-
            data.frame(x = c(-1, 1, 1,-1,-1, 1, 1,-1) / 2,
                       y = c(-1,-1,-1,-1, 1, 1, 1, 1) / 2 * aspect[1],
                       z = c(-1,-1, 1, 1,-1,-1, 1, 1) / 2 * aspect[2])

        zlim.scaled <- range(corners$z) ## needed in panel.3dscatter for type = 'h'
        ## denotes z range of bounding box 
        
        ## center of bounding box:
        box.center <- matrix(unlist(lapply(corners, mean)), 3, 1)
        
        ## these are box boundaries:
        pre <- c(1,2,4,1,2,3,4,1,5,6,8,5)
        nxt <- c(2,3,3,4,6,7,8,5,6,7,7,8)

        ## The corners are defined in terms of coordinates in 3-D
        ## space as above. The actual choice of coordinates ideally
        ## should not affect anything, but I haven't checked. Box
        ## boundaries are defined as pairs of corners. The numbers of
        ## the corners and boundaries are helpful in keeping track of
        ## things, and are described in the diagram below.


        ## 1, 2, ..., 8 are the corners, L-1, ..., L-12 the boundaries        
        ##                          
        ##                                   L-11                  
        ##                           8------------------------7    
        ##                         / |                       / |    
        ##                        /  |                      /  |    
        ##                    L-7/   |L-12              L-6/   |    
        ##                      /    |                    /    |    
        ##                     /     |                   /     |    
        ##                    /      |        L-3       /      |L-10 
        ##                   4-------------------------3       |
        ##                   |       |                 |       |
        ##                   |       |                 |       |
        ##                   |       |                 |       |
        ##                   |       |    L-9          |       |
        ##                L-4|       5-----------------|-------6 
        ##                   |      /                  |      / 
        ##                   |     /                   |     /  
        ##                   |    /                 L-2|    /L-5
        ##                   |   /                     |   / 
        ##                   |  /L-8                   |  / 
        ##                   | /                       | /
        ##                   |/                        |/
        ##                   1-------------------------2
        ##                (0,0,0)          L-1           
        ##                                            
        ##
        ## Also the 6 FACES are defined in terms of corners (lines)
        ## as follows:
        ##
        ## F-1 : 1,2,3,4 (1,2,3,4)
        ## F-2 : 2,6,7,3 (5,10,6,2)
        ## F-3 : 6,5,8,7 (9,12,11,10)
        ## F-4 : 5,1,4,8 (8,4,7,12)
        ## F-5 : 1,2,6,5 (1,5,9,8)
        ## F-6 : 4,3,7,8 (3,6,11,7)

        face.corners <- list(c(1,2,3,4),
                             c(2,6,7,3),
                             c(6,5,8,7),
                             c(5,1,4,8),
                             c(1,2,6,5),
                             c(4,3,7,8))

        face.lines <- list(c(1,2,3,4),
                           c(5,10,6,2),
                           c(9,12,11,10),
                           c(8,4,7,12),
                           c(1,5,9,8),
                           c(3,6,11,7))
        
        ## SCALES : very beta

        tmp <- ltransform3dto3d(t(as.matrix(corners)), rot.mat)
        farthest <- 1  ## used later also
        farval <- tmp[3,1]

        for (i in 2:8)
            if (tmp[3,i] < farval) {
                farthest <- i
                farval <- tmp[3,i]
            }

        ## not foolproof, need to revisit this later
        scale.position <-
            if (farthest == 1) list(x = 3, y = 7, z = 2)
            else if (farthest == 2) list(x = 9, y = 8, z = 10)
            else if (farthest == 3) list(x = 11, y = 7, z = 10)
            else if (farthest == 4) list(x = 11, y = 6, z = 2)
            else if (farthest == 5) list(x = 1, y = 5, z = 4)
            else if (farthest == 6) list(x = 1, y = 8, z = 12)
            else if (farthest == 7) list(x = 3, y = 7, z = 2)
            else if (farthest == 8) list(x = 3, y = 6, z = 10)

        ##original:
            #if (farthest == 1) list(x = 9, y = 5, z = 2)
            #else if (farthest == 2) list(x = 9, y = 8, z = 10)
            #else if (farthest == 3) list(x = 11, y = 7, z = 10)
            #else if (farthest == 4) list(x = 11, y = 6, z = 2)
            #else if (farthest == 5) list(x = 1, y = 5, z = 4)
            #else if (farthest == 6) list(x = 1, y = 8, z = 12)
            #else if (farthest == 7) list(x = 3, y = 7, z = 2)
            #else if (farthest == 8) list(x = 3, y = 6, z = 10)
        if (!missing(scpos))
            scale.position[names(scpos)] <- scpos

        scpos <- scale.position

        
        labs <- rbind(x = c(0, corners$x[pre[scpos$y]], corners$x[pre[scpos$z]]),
                      y = c(corners$y[pre[scpos$x]], 0, corners$y[pre[scpos$z]]),
                      z = c(corners$z[pre[scpos$x]], corners$z[pre[scpos$y]], 0))

        labs[,1] <- labs[,1] * (1 + scales.3d$x.scales$distance/3)
        labs[,2] <- labs[,2] * (1 + scales.3d$y.scales$distance/3)
        labs[,3] <- labs[,3] * (1 + scales.3d$z.scales$distance/3)

        axes <- rbind(x = 
                      c(proportion * corners$x[c(pre[scpos$x], nxt[scpos$x])],
                        corners$x[c(pre[scpos$y], nxt[scpos$y])],
                        corners$x[c(pre[scpos$z], nxt[scpos$z])]),
                      y = 
                      c(corners$y[c(pre[scpos$x], nxt[scpos$x])],
                        proportion * corners$y[c(pre[scpos$y], nxt[scpos$y])],
                        corners$y[c(pre[scpos$z], nxt[scpos$z])]),
                      z = 
                      c(corners$z[c(pre[scpos$x], nxt[scpos$x])],
                        corners$z[c(pre[scpos$y], nxt[scpos$y])],
                        proportion * corners$z[c(pre[scpos$z], nxt[scpos$z])]))
            
        axes[,1:2] <- axes[,1:2] * (1 + scales.3d$x.scales$distance/10)
        axes[,3:4] <- axes[,3:4] * (1 + scales.3d$y.scales$distance/10)
        axes[,5:6] <- axes[,5:6] * (1 + scales.3d$z.scales$distance/10)



        ## FIXME: The following should be split into blocks of
        ## is.characterOrExpression(xlim)...

        x.at <-
            if (is.logical(scales.3d$x.scales$at)) 
                if (is.characterOrExpression(xlim)) seq(along = xlim)
                else lpretty(xlim, scales.3d$x.scales$tick.number)
            else scales.3d$x.scales$at
        y.at <- 
            if (is.logical(scales.3d$y.scales$at)) 
                if (is.characterOrExpression(ylim)) seq(along = ylim)
                else lpretty(ylim, scales.3d$y.scales$tick.number)
            else scales.3d$y.scales$at
        z.at <- 
            if (is.logical(scales.3d$z.scales$at)) 
                if (is.characterOrExpression(zlim)) seq(along = zlim)
                else lpretty(zlim, scales.3d$z.scales$tick.number)
            else scales.3d$z.scales$at
        x.at.lab <-
            if (is.logical(scales.3d$x.scales$labels))
                if (is.characterOrExpression(xlim)) xlim
                else as.character(x.at)
            else as.character(scales.3d$x.scales$labels)
        y.at.lab <-
            if (is.logical(scales.3d$y.scales$labels))
                if (is.characterOrExpression(ylim)) ylim
                else as.character(y.at)
            else as.character(scales.3d$y.scales$labels)
        z.at.lab <-
            if (is.logical(scales.3d$z.scales$labels))
                if (is.characterOrExpression(zlim)) zlim
                else as.character(z.at)
            else as.character(scales.3d$z.scales$labels)
        if (is.characterOrExpression(xlim)) {
            xlim <- c(0, length(xlim) + 1)
        }
        if (is.characterOrExpression(ylim)) {
            ylim <- c(0, length(ylim) + 1)
        }
        if (is.characterOrExpression(zlim)) {
            zlim <- c(0, length(zlim) + 1)
        }
        x.at <- x.at[x.at >= xlim[1] & x.at <= xlim[2]]
        y.at <- y.at[y.at >= ylim[1] & y.at <= ylim[2]]
        z.at <- z.at[z.at >= zlim[1] & z.at <= zlim[2]]

        x.at.lab <- x.at.lab[x.at >= xlim[1] & x.at <= xlim[2]]
        y.at.lab <- y.at.lab[y.at >= ylim[1] & y.at <= ylim[2]]
        z.at.lab <- z.at.lab[z.at >= zlim[1] & z.at <= zlim[2]]

        

        ## box ranges and lengths
        cmin <- lapply(corners, min)
        cmax <- lapply(corners, max)
        clen <- lapply(corners, function(x) diff(range(x)))


        ## scaled (to bounding box) data
        x <- cmin$x + clen$x * (x-xlim[1])/diff(xlim)
        y <- cmin$y + clen$y * (y-ylim[1])/diff(ylim)
        z <- cmin$z + clen$z * (z-zlim[1])/diff(zlim)
        col.at <- cmin$z + clen$z * (col.at - zlim[1])/diff(zlim)

        zero.scaled <- cmin$z - clen$z * zlim[1]/diff(zlim)
        ## needed in panel.3dscatter for type = 'h'


        x.at <- cmin$x + clen$x * (x.at-xlim[1])/diff(xlim)
        y.at <- cmin$y + clen$y * (y.at-ylim[1])/diff(ylim)
        z.at <- cmin$z + clen$z * (z.at-zlim[1])/diff(zlim)
        at.len <- length(x.at)
        x.at <- rbind(x = x.at,
                      y = rep(corners$y[pre[scpos$x]], at.len),
                      z = rep(corners$z[pre[scpos$x]], at.len))
        at.len <- length(y.at)
        y.at <- rbind(x = rep(corners$x[pre[scpos$y]], at.len),
                      y = y.at,
                      z = rep(corners$z[pre[scpos$y]], at.len))
        at.len <- length(z.at)
        z.at <- rbind(x = rep(corners$x[pre[scpos$z]], at.len),
                      y = rep(corners$y[pre[scpos$z]], at.len),
                      z = z.at)

        x.at.end <- x.at + scales.3d$x.scales$tck * .05 * labs[,1]
        y.at.end <- y.at + scales.3d$y.scales$tck * .05 * labs[,2]
        z.at.end <- z.at + scales.3d$z.scales$tck * .05 * labs[,3]

        x.labs <- x.at + 2 * scales.3d$x.scales$tck * .05 * labs[,1]
        y.labs <- y.at + 2 * scales.3d$y.scales$tck * .05 * labs[,2]
        z.labs <- z.at + 2 * scales.3d$z.scales$tck * .05 * labs[,3]

        ## Things necessary for perspective
        tmp <- ltransform3dto3d(t(as.matrix(corners)), rot.mat)
        zback <- min(tmp[3,])
        zfront <- max(tmp[3,])
        za <- (zfront * (1-distance) - zback) / (zfront - zback)
        zb <- distance / (zfront - zback)

        corners <- ltransform3dto3d(t(as.matrix(corners)), rot.mat, za, zb, zback, zfront, distance)

        taxes <- ltransform3dto3d(axes, rot.mat, za, zb, zback, zfront, distance)
        x.at <- ltransform3dto3d(x.at, rot.mat, za, zb, zback, zfront, distance)
        x.labs <- ltransform3dto3d(x.labs, rot.mat, za, zb, zback, zfront, distance)
        x.at.end <- ltransform3dto3d(x.at.end, rot.mat, za, zb, zback, zfront, distance)

        y.at <- ltransform3dto3d(y.at, rot.mat, za, zb, zback, zfront, distance)
        y.labs <- ltransform3dto3d(y.labs, rot.mat, za, zb, zback, zfront, distance)
        y.at.end <- ltransform3dto3d(y.at.end, rot.mat, za, zb, zback, zfront, distance)

        z.at <- ltransform3dto3d(z.at, rot.mat, za, zb, zback, zfront, distance)
        z.labs <- ltransform3dto3d(z.labs, rot.mat, za, zb, zback, zfront, distance)
        z.at.end <- ltransform3dto3d(z.at.end, rot.mat, za, zb, zback, zfront, distance)

        tlabs <- ltransform3dto3d(labs, rot.mat, za, zb, zback, zfront, distance)

        box.center <- ltransform3dto3d(box.center, rot.mat, za, zb, zback, zfront, distance)

        ## Shall now determine which bounding lines should be 'hidden'
        ## (by the data, and hence need to be drawn before the data),
        ## and which should be 'visible'. Will actually consider each
        ## face (one at a time), determine if it is 'visible' (had the
        ## bounding cube been opaque), and if so, mark the lines
        ## forming that face as 'visible'

        ## The logical vector 'mark' will correspond to the 12 lines
        ## (indexing explained in the diagram above). mark = TRUE will
        ## mean that the line will be drawn AFTER the data is
        ## drawn. Start off with all fark = FALSE.

        ## The idea is that for visible faces, the z-value of the
        ## center of the face will be greater than the z-value of the
        ## center of the whole box

        ##print(box.center)
        mark <- rep(FALSE, 12)
        box.center.z <- box.center[3]

        for (face in 1:6)
            if (mean(corners[3, face.corners[[face]] ]) > box.center.z) ## i.e., face visible
                mark[1:12 %in% face.lines[[face]] ] <- TRUE

        #for (j in 1:12)
        #    if (pre[j]==farthest || nxt[j]==farthest)
        #        mark[j] <- FALSE

        ## This draws the 'back' of the box, i.e., the portion that
        ## should be hidden by the data. This doesn't work properly in
        ## the case where the whole 'back rectangle' is 'contained'
        ## within the 'front rectangle'.

        lsegments(corners[1, pre[!mark]],
                  corners[2, pre[!mark]],
                  corners[1, nxt[!mark]],
                  corners[2, nxt[!mark]],
                  col = par.box.final$col,
                  lwd = par.box.final$lwd,
                  lty = 2)


        ## The following portion of code is responsible for drawing
        ## the part of the plot driven by the data. The modus operandi
        ## will be different for cloud and wireframe, since they have
        ## essentially different purpose. For cloud, the data is
        ## unstructured, and x, y and z are all passed to the
        ## panel.3d.cloud function. For wireframe, on the other hand,
        ## x and y must form a regular grid, which sort(unique(<x|y>))
        ## is enough to describe (o.w., very real memory problems
        ## possible). z would then have to be supplied in a very
        ## particular order. All this is fine, but a problem arises if
        ## we want to allow groups -- multiple surfaces. One option is
        ## to supply a matrix (nx * ny by no.of.groups) for z. This is
        ## OK, but it precludes the posibility of supplying x and y as
        ## only their unique values from the very beginning. Let's do
        ## it this way for now.


        if (wireframe) {
            panel.3d.wireframe <- 
                if (is.character(panel.3d.wireframe)) get(panel.3d.wireframe)
                else eval(panel.3d.wireframe)

            if (is.null(groups)) {
                ord <- order(x, y)
                tmp <- z[ord]

                nx <- length(unique(x))
                ny <- length(unique(y))
                len <- length(z)
                if (nx * ny != len) stop("Incorrect arguments")
            }
            else {
                vals <- sort(unique(groups))
                nvals <- length(vals)
                tmp <- numeric(0)

                for (i in seq(along=vals)) {
                    id <- (groups[subscripts] == vals[i])
                    if (any(id)) {
                        ord <- order(x[id], y[id])
                        tmp <- cbind(tmp, z[id][ord])
                    }
                }

            }
            x <- sort(unique(x))
            y <- sort(unique(y))
            z <- NULL ## hopefully becomes garbage, collected if necessary


            panel.3d.wireframe(x = x, y = y, z = tmp,
                               rot.mat = rot.mat,
                               za = za, zb = zb,
                               minz = cmin$z,
                               maxz = cmax$z,
                               col.at = col.at,
                               col.regions = col.regions,
                               ...)
        }
        else {
            panel.3d.cloud <- 
                if (is.character(panel.3d.cloud)) get(panel.3d.cloud)
                else eval(panel.3d.cloud)
            panel.3d.cloud(x = x, y = y, z = z,
                           rot.mat = rot.mat,
                           za=za, zb=zb, zback, zfront, distance,
                           zlim = zlim.scaled,
                           zero = zero.scaled,
                           subscripts = subscripts,
                           groups = groups,
                           ...)
        }





        ## This draws the front of the bounding box

        lsegments(corners[1, pre[mark]],
                  corners[2, pre[mark]],
                  corners[1, nxt[mark]],
                  corners[2, nxt[mark]],
                  col = par.box.final$col,
                  lty = par.box.final$lty,
                  lwd = par.box.final$lwd)

        ## Next part for axes : beta
        
        if (scales.3d$x.scales$draw) {
            if (scales.3d$x.scales$arrows) {
                larrows(x0 = taxes[1, 1], y0 = taxes[2, 1],
                        x1 = taxes[1, 2], y1 = taxes[2, 2],
                        lty = scales.3d$x.scales$lty,
                        lwd = scales.3d$x.scales$lwd,
                        col = scales.3d$x.scales$col)
            }
            else {
                lsegments(x0 = x.at[1,], y0 = x.at[2,], x1 = x.at.end[1,], y1 = x.at.end[2,],
                          lty = scales.3d$x.scales$lty,
                          col = scales.3d$x.scales$col,
                          lwd = scales.3d$x.scales$lwd)
                ltext(x.at.lab, x = x.labs[1,], y = x.labs[2,],
                      cex = scales.3d$x.scales$cex,
                      font = scales.3d$x.scales$font,
                      col = scales.3d$x.scales$col)
            }
        }

        if (scales.3d$y.scales$draw) {
            if (scales.3d$y.scales$arrows) {
                larrows(x0 = taxes[1, 3], y0 = taxes[2, 3],
                        x1 = taxes[1, 4], y1 = taxes[2, 4],
                        lty = scales.3d$y.scales$lty,
                        lwd = scales.3d$y.scales$lwd,
                        col = scales.3d$y.scales$col)
            }
            else {
                lsegments(x0 = y.at[1,], y0 = y.at[2,], x1 = y.at.end[1,], y1 = y.at.end[2,],
                          lty = scales.3d$y.scales$lty,
                          col = scales.3d$y.scales$col,
                          lwd = scales.3d$y.scales$lwd)
                ltext(y.at.lab, x = y.labs[1,], y = y.labs[2,],
                      cex = scales.3d$y.scales$cex,
                      font = scales.3d$y.scales$font,
                      col = scales.3d$y.scales$col)
            }
        }
        if (scales.3d$z.scales$draw) {
            if (scales.3d$z.scales$arrows) {
                larrows(x0 = taxes[1, 5], y0 = taxes[2, 5],
                        x1 = taxes[1, 6], y1 = taxes[2, 6],
                        lty = scales.3d$z.scales$lty,
                        lwd = scales.3d$z.scales$lwd,
                        col = scales.3d$z.scales$col)
            }
            else {
                lsegments(x0 = z.at[1,], y0 = z.at[2,], x1 = z.at.end[1,], y1 = z.at.end[2,],
                          lty = scales.3d$z.scales$lty,
                          col = scales.3d$x.scales$col,
                          lwd = scales.3d$z.scales$lwd)
                ltext(z.at.lab, x = z.labs[1,], y = z.labs[2,],
                      cex = scales.3d$z.scales$cex,
                      font = scales.3d$z.scales$font,
                      col = scales.3d$z.scales$col)
            }
        }

        if (!is.null(xlab)) ltext(xlab$lab, x = tlabs[1, 1], y = tlabs[2, 1],
                                  cex = xlab$cex, rot = xlab$rot,
                                  font = xlab$font, col = xlab$col)
        
        if (!is.null(ylab)) ltext(ylab$lab, x = tlabs[1, 2], y = tlabs[2, 2],
                                  cex = ylab$cex, rot = ylab$rot,
                                  font = ylab$font, col = ylab$col)
                                  
        if (!is.null(zlab)) ltext(zlab$lab, x = tlabs[1, 3], y = tlabs[2, 3],
                                  cex = zlab$cex, rot = zlab$rot,
                                  font = zlab$font, col = zlab$col)
    }
}








panel.wireframe <- function(...)
    panel.cloud(..., wireframe = TRUE)





wireframe <-
    function(formula,
             data = parent.frame(),
             panel = "panel.wireframe",
             prepanel = NULL,
             strip = TRUE,
             groups = NULL,
             cuts = 70,
             pretty = FALSE,
             drape = FALSE,
             ...,
             col.regions = trellis.par.get("regions")$col,
             colorkey = any(drape),
             subset = TRUE)
{
    ##warning("wireframe can be EXTREMELY slow")
    ## m <- match.call(expand.dots = FALSE)
    dots <- list(...)
    groups <- eval(substitute(groups), data, parent.frame())
    subset <- eval(substitute(subset), data, parent.frame())

    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)

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

    do.call("cloud",
            c(list(formula = formula, data = data,
                   groups = groups, subset = subset,
                   panel = panel, prepanel = prepanel, strip = strip,
                   cuts = cuts, 
                   pretty = pretty,
                   col.regions = col.regions,
                   drape = drape,
                   colorkey = colorkey),
              dots))
}























cloud <-
    function(formula,
             data = parent.frame(),
             allow.multiple = FALSE,
             outer = FALSE,
             auto.key = FALSE,
             aspect = c(1,1),
             layout = NULL,
             panel = "panel.cloud",
             prepanel = NULL,
             scales = NULL,
             strip = TRUE,
             groups = NULL,
             xlab,
             xlim = if (is.factor(x)) levels(x) else range(x),
             ylab,
             ylim = if (is.factor(y)) levels(y) else range(y),
             zlab,
             zlim = if (is.factor(z)) levels(z) else range(z),
             distance = .2,
             perspective = TRUE,
             R.mat = diag(4),
             screen = list(z = 40, x = -60),
             zoom = .8,
             at,
             pretty = FALSE,
             drape = FALSE,
             ...,
             colorkey = any(drape),
             col.regions, cuts = 1,
             subscripts = TRUE,
             subset = TRUE)
{

    ##dots <- eval(substitute(list(...)), data, parent.frame())
    dots <- list(...)

    groups <- eval(substitute(groups), data, parent.frame())
    subset <- eval(substitute(subset), data, parent.frame())

    ## Step 1: Evaluate x, y, z etc. and do some preprocessing

    formula <- eval(substitute(formula), data, parent.frame())
    form <-
        if (inherits(formula, "formula"))
            latticeParseFormula(formula, data, dim = 3, subset = subset,
                                groups = groups, multiple = allow.multiple,
                                outer = outer, subscripts = TRUE)
        else {
            if (!is.matrix(formula)) stop("invalid formula")
            else {
                tmp <- expand.grid(1:nrow(formula), 1:ncol(formula))
                list(left = as.vector(formula),
                     right.x = tmp[[1]],
                     right.y = tmp[[2]],
                     condition = NULL,
                     left.name = "",
                     right.x.name = "", right.y.name = "")
            }
        }

    groups <- form$groups

    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)
    
    if ("subscripts" %in% names(formals(panel))) subscripts <- TRUE
    if (subscripts) subscr <- form$subscr

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


    cond <- form$condition
    number.of.cond <- length(cond)
    z <- form$left
    x <- form$right.x
    y <- form$right.y

    if (number.of.cond == 0) {
        strip <- FALSE
        cond <- list(as.factor(rep(1, length(x))))
        layout <- c(1,1,1)
        number.of.cond <- 1
    }
    
    if (missing(xlab)) xlab <- form$right.x.name
    if (missing(ylab)) ylab <- form$right.y.name
    if (missing(zlab)) zlab <- form$left.name

    ##if(!(is.numeric(x) && is.numeric(y) && is.numeric(z)))
    ##    warning("x, y and z should be numeric")
    ##x <- as.numeric(x)
    ##y <- as.numeric(y)
    ##z <- as.numeric(z)

    zrng <- extend.limits(range(z[!is.na(z)]))
    if (missing(at))
        at <-
            if (pretty) lpretty(zrng, cuts)
            else seq(zrng[1], zrng[2], length = cuts+2)
    

    ## create a skeleton trellis object with the
    ## less complicated components:

    foo <- do.call("trellis.skeleton",
                   c(list(aspect = 1,
                          strip = strip,
                          panel = panel,
                          xlab = NULL,
                          ylab = NULL), dots))
                          
    ##-----------------------------------------------------------
    ## xlab, ylab, zlab have special meaning in cloud / wireframe

    if (!is.null(xlab)) {
        text <- trellis.par.get("par.xlab.text")
        if (is.null(text)) text <- list(cex = 1, col = "black", font = 1)
        xlab <-
            list(label =
                 if (is.characterOrExpression(xlab)) xlab
                 else xlab[[1]],
                 col = text$col, rot = 0,
                 cex = text$cex, font = text$font)
        if (is.list(xlab)) xlab[names(xlab)] <- xlab
    }
    if (!is.null(ylab)) {
        text <- trellis.par.get("par.ylab.text")
        if (is.null(text)) text <- list(cex = 1, col = "black", font = 1)
        ylab <-
            list(label =
                 if (is.characterOrExpression(ylab)) ylab
                 else ylab[[1]],
                 col = text$col,  rot = 0,
                 cex = text$cex, font = text$font)
        if (is.list(ylab)) ylab[names(ylab)] <- ylab
    }
    if (!is.null(zlab)) {
        text <- trellis.par.get("par.zlab.text")
        if (is.null(text)) text <- list(cex = 1, col = "black", font = 1)
        zlab <-
            list(label =
                 if (is.characterOrExpression(zlab)) zlab
                 else zlab[[1]],
                 col = text$col, rot = 0,
                 cex = text$cex, font = text$font)
        if (is.list(zlab)) zlab[names(zlab)] <- zlab
    }
    ##-----------------------------------------------------------------


    dots <- foo$dots # arguments not processed by trellis.skeleton
    foo <- foo$foo
    foo$call <- match.call()

    ## This is for cases like xlab/ylab = list(cex=2)
    if (is.list(xlab) && !is.characterOrExpression(xlab$label))
        xlab$label <- form$right.x.name
    if (is.list(ylab) && !is.characterOrExpression(ylab$label))
        ylab$label <- form$right.y.name
    if (is.list(zlab) && !is.characterOrExpression(zlab$label))
        zlab$label <- form$left.name

    ## Step 2: Compute scales.common (leaving out limits for now)

    foo <- c(foo,
             do.call("construct.scales", list(draw=FALSE)))

    ## scales has to be interpreted differently. Nothing needs to be
    ## done for the ususal scales, but need a scales for panel.cloud
    ## Splus probably doesn't allow x-y-z-specific scales, but I see
    ## no reason not to allow that (will not allow limits, though)


    scales.default <-
        list(cex = .8, col = "black", lty = 1,
             lwd = 1, tck = 1, distance = c(1, 1, 1),
             arrows = TRUE)
    if (!is.null(scales)) scales.default[names(scales)] <- scales
    scales.3d <- do.call("construct.3d.scales", scales.default)

    ## Step 3: Decide if limits were specified in call:
    ## Here, always FALSE (in the 2d panel sense)
    have.xlim <- FALSE
    have.ylim <- FALSE

    ## Step 4: Decide if log scales are being used: !!!

    have.xlog <- !is.logical(scales.3d$x.scales$log) || scales.3d$x.scales$log
    have.ylog <- !is.logical(scales.3d$y.scales$log) || scales.3d$y.scales$log
    have.zlog <- !is.logical(scales.3d$z.scales$log) || scales.3d$z.scales$log
    if (have.xlog) {
        xlog <- scales.3d$x.scales$log
        xbase <-
            if (is.logical(xlog)) 10
            else if (is.numeric(xlog)) xlog
            else if (xlog == "e") exp(1)

        x <- log(x, xbase)
        xlim <- log(xlim, xbase)
    }
    if (have.ylog) {
        ylog <- scales.3d$y.scales$log
        ybase <-
            if (is.logical(ylog)) 10
            else if (is.numeric(ylog)) ylog
            else if (ylog == "e") exp(1)

        y <- log(y, ybase)
        ylim <- log(ylim, ybase)
    }
    if (have.zlog) {
        zlog <- scales.3d$z.scales$log
        zbase <-
            if (is.logical(zlog)) 10
            else if (is.numeric(zlog)) zlog
            else if (zlog == "e") exp(1)

        z <- log(z, zbase)
        zlim <- log(zlim, zbase)
    }
    
    ## Step 5: Process cond

    cond.max.level <- unlist(lapply(cond, nlevels))


    id.na <- is.na(x)|is.na(y)|is.na(z)
    for (var in cond)
        id.na <- id.na | is.na(var)
    if (!any(!id.na)) stop("nothing to draw")
    ## Nothing simpler ?

    foo$condlevels <- lapply(cond, levels)

    ## Step 6: Evaluate layout, panel.args.common and panel.args





    ## calculate rotation matrix:


#     rot.mat <- diag(3)
#     screen.names <- names(screen)
#     screen <- lapply(screen, "*", pi/180)

#     for(i in seq(along=screen.names)) {
#         th <- screen[[i]]
#         cth <- cos(th)
#         sth <- sin(th)
#         tmp.mat <- 
#             (if (screen.names[i]=="x")
#              matrix(c(1, 0, 0, 0, cth, sth, 0, -sth, cth), 3, 3)
#             else if (screen.names[i]=="y")
#              matrix(c(cth, 0, -sth, 0, 1, 0, sth, 0, cth), 3, 3)
#             else if (screen.names[i]=="z")
#              matrix(c(cth, sth, 0, -sth, cth, 0, 0, 0, 1), 3, 3))
#         rot.mat <- tmp.mat %*% rot.mat
#     }


    rot.mat <- ltransform3dMatrix(screen = screen, R.mat = R.mat)

    if (drape) {
        ## region
        numcol <- length(at)-1
        numcol.r <- length(col.regions)

        col.regions <-
            if (numcol.r <= numcol)
                rep(col.regions, length = numcol)
            else col.regions[floor(1+(1:numcol-1)*(numcol.r-1)/(numcol-1))]
    
        if (is.logical(colorkey)) {
            if (colorkey) foo$colorkey <-
                list(space = "right", col = col.regions,
                     at = at, tick.number = 7)
        }
        else if (is.list(colorkey)) {
            foo$colorkey <- colorkey
            if (is.null(foo$colorkey$col)) foo$colorkey$col <- col.regions
            if (is.null(foo$colorkey$at)) foo$colorkey$at <- at
        }
    }
    else {
        col.regions <- trellis.par.get("background")$col
    }


    ## maybe *lim = NULL with relation = "free" ? 
    foo$panel.args.common <-
        c(list(x=x, y=y, z=z, rot.mat = rot.mat, zoom = zoom,
               xlim = xlim, ylim = ylim, zlim = zlim,
               xlab = xlab, ylab = ylab, zlab = zlab,
               aspect = aspect,
               distance = if (perspective) distance else 0,
               scales.3d = scales.3d,
               col.at = at, col.regions = col.regions),
          dots)

    if (!is.null(groups)) foo$panel.args.common$groups <- groups

    layout <- compute.layout(layout, cond.max.level, skip = foo$skip)
    plots.per.page <- max(layout[1] * layout[2], layout[2])
    number.of.pages <- layout[3]
    foo$skip <- rep(foo$skip, length = plots.per.page)
    foo$layout <- layout
    nplots <- plots.per.page * number.of.pages

    foo$panel.args <- as.list(1:nplots)
    cond.current.level <- rep(1,number.of.cond)
    panel.number <- 1 # this is a counter for panel number

    for (page.number in 1:number.of.pages)
        if (!any(cond.max.level-cond.current.level<0))
            for (plot in 1:plots.per.page) {

                if (foo$skip[plot]) foo$panel.args[[panel.number]] <- FALSE
                else if(!any(cond.max.level-cond.current.level<0)) {

                    id <- !id.na
                    for(i in 1:number.of.cond)
                    {
                        var <- cond[[i]]
                        id <- id &
                        if (is.shingle(var))
                            ((var >=
                              levels(var)[[cond.current.level[i]]][1])
                             & (var <=
                                levels(var)[[cond.current.level[i]]][2]))
                        else (as.numeric(var) == cond.current.level[i])
                    }

                    foo$panel.args[[panel.number]] <- 
                        list(subscripts = subscr[id])

                    cond.current.level <-
                        cupdate(cond.current.level,
                                cond.max.level)
                }

                panel.number <- panel.number + 1
            }

    foo <- c(foo,
             limits.and.aspect(prepanel.default.cloud,
                               prepanel = prepanel,
                               have.xlim = have.xlim, xlim = xlim, 
                               have.ylim = have.ylim, ylim = ylim, 
                               x.relation = foo$x.scales$relation,
                               y.relation = foo$y.scales$relation,
                               panel.args.common = foo$panel.args.common,
                               panel.args = foo$panel.args,
                               aspect = 1,
                               nplots = nplots))

    if (is.null(foo$key) && !is.null(groups) &&
        (is.list(auto.key) || (is.logical(auto.key) && auto.key)))
        foo$key <- do.call("simpleKey",
                           c(list(levels(as.factor(groups))),
                             if (is.list(auto.key)) auto.key else list()))

    class(foo) <- "trellis"
    foo
}








### Copyright 2001-2003  Deepayan Sarkar <deepayan@stat.wisc.edu>
### Copyright 2001-2003  Saikat DebRoy <saikat@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA




cupdate <- function(index, maxim)
{
    ##  This function is used to handle arbitrary number of
    ## conditioning variables : every time it is called, it
    ## increments the "current" level of the conditioning
    ## variables suitably, i.e., it tries to increment the
    ## level of the 1st conditining variable (the one which
    ## varies fastest along panel order) and if it happens
    ## to be at its maximum (last) value, it sets it to the
    ## first value AND increments the "current" level of the
    ## 2nd (next) conditioning variable recursively.

    ## This is an internal function, not to be documented
    ## for the high level user.
    
    if(length(index)!=length(maxim)||length(maxim)<=0)
        stop("Inappropriate arguments")
    index[1] <- index[1] + 1
    if(index[1]>maxim[1] && length(maxim)>1)
        c(1,cupdate(index[-1],maxim[-1]))
    else index
}





generateNewName <- function(names.current, new.prefix="gvar")
{
    names.current <- as.character(names.current)
    new.prefix <- as.character(new.prefix)
    newnames <- c(new.prefix,
                  paste(gvar, seq(along=names.current), sep=""))
    newnames[!(newnames %in% names.current)][1]
}





latticeParseFormula <-
    function(model, data, dimension = 2, subset = TRUE,
             groups = NULL, multiple = FALSE, outer = FALSE,
             subscripts = FALSE)
    ## this function mostly written by Saikat
{
    parseSide <-
        function(model)
        {
            model.vars <- list()
            while (length(model) == 3 && model[[1]] == as.name("+")) {
                model.vars <- c(model.vars, model[[3]])
                model <- model[[2]]
            }
            rev(c(model.vars, model))
        }

    parseCond <-
        function(model)
        {
            model <- eval(parse(text = paste("~", deparse(model))))[[2]]
            model.vars <- list()
            while (length(model) == 3 && (model[[1]] == as.name("*")
                         || model[[1]] == as.name("+"))) {
                model.vars <- c(model.vars, model[[3]])
                model <- model[[2]]
            }
            rev(c(model.vars, model))
        }

    lrep <-
        function(x, n)
        {
            save.attr <- attributes(x)
            x <- rep(x, n)
            attributes(x) <- save.attr
            x
        }

    concat <-
        function(arglist)
        {
            if (length(arglist) == 1)
                arglist[[1]]
            else if (any(sapply(arglist, is.factor))) {
                factor(unlist(lapply(arglist, as.character)))
            } else if (any(sapply(arglist, is.shingle))) {
                stop("shingles can not be concatenated")
            } else do.call("c", arglist)
        }
    
    if (!inherits(model, "formula"))
        stop("model must be a formula object")
    if (multiple && !outer && !is.null(groups))
        stop("groups argument is non NULL with multiple = TRUE and outer = FALSE")

    ans <- if (dimension == 2) {
        list(left = NULL, right = NULL, condition = NULL,
             left.name = character(0), right.name = character(0))
    }
    else if (dimension == 3) {
        list(left = NULL, right.x = NULL, right.y = NULL, condition = NULL,
             left.name = character(0), right.x.name = character(0),
             right.y.name = character(0))
    }
    else stop(paste("invalid dimension : ", dimension))

    
    if (length(model) == 3) {
        if (multiple) {
            varsLHS <- parseSide(model[[2]])
            nLHS <- length(varsLHS)
        } else {
            varsLHS <- list(model[[2]])
            nLHS <- 1
        }
    } else {
        nLHS <- 1
    }
    modelRHS <- model[[length(model)]]
    if (length(modelRHS) == 3 && modelRHS[[1]] == as.name("|"))
        modelRHS <- modelRHS[[2]]
        

    env <- environment(model)
    modelRHS <- model[[length(model)]]
    if (length(modelRHS) == 3 && modelRHS[[1]] == as.name("|")) {
        modelRHS.vars <- parseCond(modelRHS[[3]])
        modelRHS <- modelRHS[[2]]
        if (multiple && dimension == 2) {
            varsRHS <- parseSide(modelRHS)
            nRHS <- length(varsRHS)
        } else {
            varsRHS <- list(modelRHS)
            nRHS <- 1
        }
        ans$condition <- vector("list", length(modelRHS.vars))
        names(ans$condition) <- sapply(modelRHS.vars, deparse)
        for (i in seq(along = modelRHS.vars)) {
            ans$condition[[i]] <-
                lrep(as.factorOrShingle(eval(modelRHS.vars[[i]], data, env),
                                        subset, drop = TRUE), nLHS*nRHS)
        }
    } else if (multiple && dimension == 2) {
        varsRHS <- parseSide(modelRHS)
        nRHS <- length(varsRHS)
    } else {
        varsRHS <- list(modelRHS)
        nRHS <- 1
    }

    if (length(model) == 3) {
        ans$left.name <- deparse(model[[2]])
        ans$left <-
            lrep(concat(lapply(varsLHS,
                               function(i) {
                                   tmp <- eval(i, data, env)
                                   tmp <-
                                       if (is.factor(tmp) || is.shingle(tmp))
                                           tmp[subset, drop = TRUE]
                                       else
                                           tmp[subset]
                                   if (inherits(tmp, "POSIXt"))
                                       tmp <- as.POSIXct(tmp)
                                   tmp
                               })), nRHS)
    }

    if (dimension == 2) {
        if (nLHS == 1 && nRHS == 1) {
            tmp <- eval(varsRHS[[1]], data, env)
            if (is.matrix(tmp)) tmp <- as.data.frame(tmp)
            nobs <- if (is.data.frame(tmp)) nrow(tmp) else length(tmp)
            if (is.data.frame(tmp))
                ans$right <- tmp[subset, ] ## doesn't do the drop=TRUE thing for factors/shingles
            else
                ans$right <-
                    if (is.factor(tmp) || is.shingle(tmp))
                        tmp[subset, drop = TRUE]
                    else tmp[subset]
        } else {
            ans$right <-
                concat(lapply(varsRHS,
                              function(i) {
                                  tmp <- eval(i, data, env)
                                  tmp <-
                                      if (is.factor(tmp) || is.shingle(tmp))
                                          tmp[subset, drop = TRUE]
                                      else
                                          tmp[subset]
                                  tmp <-
                                      lrep(tmp, nLHS)
                                  if (inherits(tmp, "POSIXt"))
                                      tmp <- as.POSIXct(tmp)
                                  tmp
                              }))
        }
        ans$right.name <- deparse(modelRHS)
        nRows <- length(ans$right)/(nLHS * nRHS)
    }
    else if (dimension == 3 && length(modelRHS) == 3 &&
             (modelRHS[[1]] == "*" || modelRHS[[1]] == "+")) {
        tmp <- eval(modelRHS[[2]], data, env)
        nobs <- length(tmp)
        tmp <-
            if (is.factor(tmp) || is.shingle(tmp))
                tmp[subset, drop = TRUE]
            else tmp[subset]
        ans$right.x <- lrep(tmp, nLHS)
        if (inherits(ans$right.x, "POSIXt")) ans$right.x <- as.POSIXct(ans$right.x)
        tmp <- eval(modelRHS[[3]], data, env)
        tmp <-
            if (is.factor(tmp) || is.shingle(tmp))
                tmp[subset, drop = TRUE]
            else tmp[subset]
        ans$right.y <-
            lrep(tmp, nLHS)
        if (inherits(ans$right.y, "POSIXt")) ans$right.y <- as.POSIXct(ans$right.y)
        ans$right.x.name <- deparse(modelRHS[[2]])
        ans$right.y.name <- deparse(modelRHS[[3]])
        nRows <- length(ans$right.x)/nLHS
    }
    else stop("invalid model")
    
    if (nLHS > 1)
        LHSgroups <- rep(gl(nLHS, nRows, labels=sapply(varsLHS,
                                         deparse)), nRHS)
    if (nRHS > 1)
        RHSgroups <- gl(nRHS, nRows*nLHS, labels=sapply(varsRHS, deparse))
    newFactor <- 
        if (nLHS > 1 && nRHS > 1) {
            factor(paste(LHSgroups, RHSgroups, sep=" * "))
        } else if (nLHS > 1)
            LHSgroups
        else if (nRHS > 1)
            RHSgroups
        else NULL

    if (outer) {
        if (!is.null(groups)) ans$groups <- rep(groups, nLHS * nRHS)
        if (!is.null(newFactor)) {
            if (is.null(ans$cond))
                ans$condition <- list(newFactor)
            else
                ans$condition[[length(ans$condition) + 1]] <- newFactor
        }
    }
    else {
        ans$groups <-
            if (is.null(newFactor)) groups
            else newFactor
    }

    if (subscripts)
        ans$subscr <-
            if (nLHS == 1 && nRHS == 1)
                seq(length=nobs)[subset]
            else seq(length=nRows*nLHS*nRHS)
    ans
}


banking <- function(dx, dy = 1)
{
    if (is.list(dx)) {
        dy <- dx[[2]]
        dx <- dx[[1]]
    }
    if (length(dx)!=length(dy)) stop("Non matching lengths")
    id <- dx!=0 & dy!=0 & !is.na(dx) & !is.na(dy)
    if (any(id)) {
        r  <- abs(dx[id]/dy[id])
        median(r)
    }
    else 1
}






## modified from axis.POSIXct. This aims to be a general function
## which given a general 'range' x and optional at, generates the
## locations of tick marks and corresponding labels. Ultimately will
## also obviate the need for lpretty

calculateAxisComponents <-
    function (x, at = FALSE, labels = FALSE,
              have.log = FALSE, logbase = NULL, logpaste = "",
              abbreviate = NULL, minlength = 4,
              format.posixt, ...) 
{

    ## x is guaranteed to be given (possibly NA), though it might not
    ## be always necessary. Four cases, corresponding to factors
    ## (is.character(x)), shingle (inherits(x, "shingleLevel")),
    ## POSIXt (inherits(x, "POSIXt") and usual numeric. The last case
    ## will be default, and will be changed later if necessary.

    ## The code for shingles will never really be used. Shingles can
    ## also be thought of as numeric, and that's more appropriate for
    ## functions like xyplot, and limits will be just range. In
    ## functions like bwplot, things will be adjusted elsewhere when
    ## one of the variables is a shingle.

    ## Note that at and labels will never be TRUE (it's set up that
    ## way), so it's enough to check if they are is.logical(), which
    ## means they are not explicitly specified.

    ## The variables about log scales are required for cases where at
    ## is explicitly specified. In such cases, at will be
    ## log(at,base=logbase), but labels would corr to at.

    if (all(is.na(x))) {
        ans <- list(at = numeric(0),
                    labels = numeric(0),
                    check.overlap = TRUE,
                    num.limit = c(0,1))
    }
    else if (is.characterOrExpression(x)) { ## factor
        ans <- list(at = if (is.logical(at)) seq(along = x) else at,
                    labels = if (is.logical(labels)) x else labels,
                    check.overlap = FALSE)
        ans$num.limit <- c(0, length(ans$at) + 1)
    }
    else if (inherits(x, "shingleLevel")) { ## shingle
        ans <- list(at = if (is.logical(at)) seq(along = x) else at,
                    labels = if (is.logical(labels))
                    as.character(seq(along = x)) else labels,
                    check.overlap = FALSE)
        ans$num.limit <- c(0, length(ans$at) + 1)
    }
    else if (is.numeric(x) && inherits(x, "POSIXt")) { ## POSIX time
                    
        num.lim <- as.numeric(range(x))
        mat <- is.logical(at)
        mlab <- is.logical(labels)

        if (!mat)
            x <- as.POSIXct(at)
        else x <- as.POSIXct(x)
        range <- as.numeric(range(x))
        d <- range[2] - range[1]
        z <- c(range, x[is.finite(x)])
        if (d < 1.1 * 60) {
            sc <- 1
            if (missing(format.posixt)) 
                format.posixt <- "%S"
        }
        else if (d < 1.1 * 60 * 60) {
            sc <- 60
            if (missing(format.posixt)) 
                format.posixt <- "%M:%S"
        }
        else if (d < 1.1 * 60 * 60 * 24) {
            sc <- 60 * 24
            if (missing(format.posixt)) 
                format.posixt <- "%H:%M"
        }
        else if (d < 2 * 60 * 60 * 24) {
            sc <- 60 * 24
            if (missing(format.posixt)) 
                format.posixt <- "%a %H:%M"
        }
        else if (d < 7 * 60 * 60 * 24) {
            sc <- 60 * 60 * 24
            if (missing(format.posixt)) 
                format.posixt <- "%a"
        }
        else {
            sc <- 60 * 60 * 24
        }
        if (d < 60 * 60 * 24 * 50) {
            zz <- lpretty(z/sc, ...)
            z <- zz * sc
            class(z) <- c("POSIXt", "POSIXct")
            if (missing(format.posixt)) 
                format.posixt <- "%b %d"
        }
        else if (d < 1.1 * 60 * 60 * 24 * 365) {
            class(z) <- c("POSIXt", "POSIXct")
            zz <- as.POSIXlt(z)
            zz$mday <- 1
            zz$isdst <- zz$hour <- zz$min <- zz$sec <- 0
            zz$mon <- lpretty(zz$mon, ...)
            m <- length(zz$mon)
            m <- rep(zz$year[1], m)
            zz$year <- c(m, m + 1)
            z <- as.POSIXct(zz)
            if (missing(format.posixt)) 
                format.posixt <- "%b"
        }
        else {
            class(z) <- c("POSIXt", "POSIXct")
            zz <- as.POSIXlt(z)
            zz$mday <- 1
            zz$isdst <- zz$mon <- zz$hour <- zz$min <- zz$sec <- 0
            zz$year <- lpretty(zz$year, ...)
            z <- as.POSIXct(zz)
            if (missing(format.posixt)) 
                format.posixt <- "%Y"
        }
        if (!mat) 
            z <- x[is.finite(x)]
        z <- z[z >= range[1] & z <= range[2]]
        labels <- format(z, format = format.posixt)
        ans <- list(at = as.numeric(z), labels = labels,
                    check.overlap = FALSE,
                    num.limit = num.lim)
    }
    else { ## plain numeric

        ## will check for overlap only when neither at nor labels is specified

        check.overlap <-
            if (is.logical(at) && is.logical(labels)) TRUE
            else FALSE
        
        if (is.logical(at)) { # at not explicitly specified
            #eps <- 1e-10
            at <- pretty(x[is.finite(x)], ...)
            
            ## Need to do this because pretty sometimes returns things
            ## like 2.3e-17 instead of 0. Probably fixed now (??)
            #at <- ifelse(abs(at - round(at, 3)) < eps,
            #             round(at, 3), 
            #             at)
        }
        else if (have.log) { ## and at specified
            if (is.logical(labels)) labels <- as.character(at)
            at <- log(at, base = logbase)
        }
        ans <- list(at = at, labels = if (is.logical(labels))
                    paste(logpaste, format(at), sep = "") else labels,
                    check.overlap = check.overlap, num.limit =
                    range(x))
    }
    if (is.logical(abbreviate) && abbreviate)
        ans$labels <- abbreviate(ans$labels, minlength)
    ans
}






extend.limits <-
    function(lim, length=1, axs = "r",
             prop = if (axs == "i") 0 else 0.07)
{
    if (!is.numeric(lim)) NA
    else if(length(lim)==2) {
        if (lim[1]>lim[2]) stop("Improper value of limit")
        if (!missing(length) && !missing(prop))
            stop("length and prop cannot both be specified")
        if (length <= 0) stop("length must be positive")
        if (!missing(length))
        {
            prop <- (as.numeric(length) - as.numeric(diff(lim))) / (2 * as.numeric(diff(lim)))
        }
        if (lim[1]==lim[2]) lim + 0.5 * c(-length,length)
        else {
            d <- diff(as.numeric(lim))
            lim + prop * d * c(-1,1)
        }
    }
    else {
        print(lim)
        stop("improper length of lim in extend.limits")
    }
}






construct.scales <-
    function(draw = TRUE,
             axs = "r",
             tck = 1,
             tick.number = 5,
             cex = 1,
             rot = FALSE,
             at = FALSE,
             labels = FALSE,
             col = FALSE,
             log = FALSE,
             font = FALSE,
             alternating = TRUE,
             relation = "same",
             abbreviate = FALSE,
             minlength = 4,
             limits = NULL,
             x = NULL,
             y = NULL,
             ...)   ## FIXME: how to handle ...
{

    xfoo <- list(draw = draw, axs = axs, tck = tck,
                 tick.number = tick.number,
                 cex = cex,
                 rot = rot,
                 font = font,
                 at = at, labels = labels,
                 col = col, log = log,
                 alternating = alternating,
                 relation = relation,
                 abbreviate = abbreviate,
                 minlength = minlength,
                 limits = limits)
    yfoo <- xfoo
    if (!is.null(x)) {
        if (is.character(x)) x <- list(relation = x)
        xfoo[names(x)] <- x
    }
    if (is.logical(xfoo$alternating))
        xfoo$alternating <-
            if (xfoo$alternating) c(1,2)
            else 1
    if (!is.null(y)) {
        if (is.character(y)) y <- list(relation = y)
        yfoo[names(y)] <- y
    }
    if (is.logical(yfoo$alternating))
        yfoo$alternating <-
            if (yfoo$alternating) c(1,2)
            else 1
    for (nm in c("tck", "cex", "rot")) {
        xfoo[[nm]] <- rep(xfoo[[nm]], length = 2)
        yfoo[[nm]] <- rep(yfoo[[nm]], length = 2)
    }
    if (xfoo$rel == "same" && (is.list(xfoo$at) || is.list(xfoo$lab)))
        stop("the at and labels components of scales may not be lists when relation = same")
    if (yfoo$rel == "same" && (is.list(yfoo$at) || is.list(yfoo$lab)))
        stop("the at and labels components of scales may not be lists when relation = same")
    list(x.scales = xfoo, y.scales = yfoo)
}





construct.3d.scales <-
    function(draw = TRUE,
             axs = "r",
             tck = 1,
             lty = 1, lwd = 1,
             distance = c(1,1,1),
             tick.number = 5,
             cex = 1,
             rot = FALSE,
             at = FALSE,
             labels = FALSE,
             col = FALSE,
             log = FALSE,
             font = FALSE,
             arrows = TRUE,
             relation = "same",
             x = NULL,
             y = NULL,
             z = NULL,
             ...)
{
    xfoo <- list(draw = draw, axs = axs, tck = tck,
                 lty = 1, lwd = 1,
                 tick.number = tick.number,
                 cex = cex, rot = rot, font = font,
                 at = at, labels = labels,
                 col = col, log = log, arrows = arrows,
                 relation = relation)
    yfoo <- xfoo
    zfoo <- xfoo
    distance <- rep(distance, length = 3)
    xfoo$distance <- distance[1]
    yfoo$distance <- distance[2]
    zfoo$distance <- distance[3]
    if (!is.null(x)) {
        if (is.character(x)) x <- list(relation = x)
        xfoo[names(x)] <- x
    }
    if (!is.null(y)) {
        if (is.character(y)) y <- list(relation = y)
        yfoo[names(y)] <- y
    }
    if (!is.null(z)) {
        if (is.character(z)) z <- list(relation = z)
        zfoo[names(z)] <- z
    }
    list(x.scales = xfoo, y.scales = yfoo, z.scales = zfoo)
}




limits.and.aspect <-
    function(prepanel.default.function,
             prepanel = NULL,
             have.xlim = FALSE, xlim = NULL,
             have.ylim = FALSE, ylim = NULL,
             x.relation, y.relation,
             panel.args.common = list(),
             panel.args = list(),
             aspect,
             nplots,
             x.axs = "r", y.axs = "r",
             ...)  ## extra arguments for prepanel (for qqmathline)
{

    if (nplots<1) stop("need at least one panel")
    x.limits <- vector("list", nplots)
    y.limits <- vector("list", nplots)
    dxdy <- vector("list", nplots)

    for (count in 1:nplots)
    {
        if (is.list(panel.args[[count]])) {
            pargs <- c(panel.args.common, panel.args[[count]], list(...))
            tem <- do.call("prepanel.default.function", pargs)
            if (is.function(prepanel)) {
                prenames <- names(formals(prepanel))
                if (!("..." %in% prenames)) pargs <- pargs[prenames]
                pretem <- do.call("prepanel", pargs)
                tem[names(pretem)] <- pretem
            }
            x.limits[[count]] <- tem$xlim
            y.limits[[count]] <- tem$ylim
            dxdy[[count]] <- list(tem$dx, tem$dy)

        }
        else {
            x.limits[[count]] <- c(NA, NA)
            y.limits[[count]] <- c(NA, NA)
            dxdy[[count]] <- list(NA, NA)
        } 

    }


    ## Some explanation might be helpful here. The for loop above
    ## creates a list of xlims/ylims. Each of these might be either
    ## numeric (when x/y is numeric, shigle or POSIXt), or levels of a
    ## factor (that's how prepanel.default.functions are set
    ## up). However, at this point, all x.limits[[i]] must be of the
    ## same type. Returned limits must be in accordance with this
    ## type. The only exception is when relation = "free", in which
    ## case they may be different. This could happen if [xy]lim or
    ## limits is supplied as a list in the high level function.

    if (x.relation == "same") {

        ## The problem here is that we need to figure out the overall
        ## limit required from the limits of each panel. This could be
        ## a problem for two reasons. First, some panels could have no
        ## data in them, in which case the corresponding limits would
        ## be NA. Secondly, the limits could be either numeric or
        ## character vectors (the latter for factors). When relation =
        ## same, the type should be same across panels. When numeric,
        ## we just take range, leaving out NAs. But what about
        ## factors?  Is it OK to assume that all the non-NA vectors
        ## would be exactly the same ? They should be, since levels(x)
        ## would not change even if not all levels are
        ## represented. So, I'm just taking unique of all the vectors
        ## concatenated, excluding NA's

        if (have.xlim) {
            if (is.list(xlim)) stop("limits cannot be a list when relation = same")
            x.limits <- xlim
            x.slicelen <- if (is.numeric(xlim)) diff(range(xlim)) else length(xlim) + 2
        }
        else {

            ## problem here: unlist loses class, important for
            ## POSIXct. Adding temporary hack as workaround, needs
            ## more thorough handling

            ## WAS: just -- x.limits <- unlist(x.limits)

            all.na <- unlist(lapply(x.limits, function(x) all(is.na(x))))
            class.xlim <- lapply(x.limits[!all.na], class) ## a list now, may be length 0
            x.limits <- unlist(x.limits)
            



            if (length(x.limits) > 0) {
                if (is.numeric(x.limits)) {
                    x.limits <- extend.limits(range(x.limits, na.rm = TRUE), axs = x.axs)
                    x.slicelen <- diff(range(x.limits))
                }
                else {
                    x.limits <- unique(x.limits[!is.na(x.limits)])
                    x.slicelen <- length(x.limits) + 2
                }
                ## put back POSIXct class (can't put back all, because 1:10 has class integer)
                if (length(class.xlim) > 0 && all(class.xlim[[1]] == c("POSIXt", "POSIXct")))
                    class(x.limits) <- c("POSIXt", "POSIXct")
            }
            else {
                x.limits <- c(0,1)
                x.slicelen <- 1
            }
        }
    }


    else if (x.relation == "sliced") {

        if (have.xlim) {
            if (is.list(xlim)) {
                x.limits <- rep(xlim, length = nplots)
            }
            else warning("Explicitly specified x-limits ignored")
        }
        x.slicelen <- x.limits
        for (i in seq(along = x.limits))
            x.slicelen[[i]] <-
                if (is.numeric(x.limits[[i]]))
                    diff(range(x.limits[[i]])) # range unnecessary, but...
                else NA
        x.slicelen <- (if (x.axs == "i") 1 else 1.14) * max(unlist(x.slicelen), na.rm = TRUE)
        for (i in seq(along = x.limits)) {
            if (is.numeric(x.limits[[i]]))
                x.limits[[i]] <-
                    extend.limits(x.limits[[i]], length = x.slicelen)
        }
    }


    else if (x.relation == "free") {

        if (have.xlim) {
            if (!is.list(xlim)) xlim <- list(xlim)

            id <- logical(length(x.limits))
            for (i in seq(along = id)) 
                id[i] <- !any(is.na(x.limits[[i]]))
            id <- seq(along = id)[id]
            id <- id[!is.na(id)]
            
            x.limits[id] <- xlim
        }

        for (i in seq(along = x.limits)) {
            if (is.numeric(x.limits[[i]])) 
                x.limits[[i]] <- extend.limits(x.limits[[i]], axs = x.axs)
            ## o.w., keep it as it is
        }
    }




    if (y.relation == "same")
        if (have.ylim) {
            if (is.list(ylim)) stop("limits cannot be a list when relation = same")
            y.limits <- ylim
            y.slicelen <- if (is.numeric(ylim)) diff(range(ylim)) else length(ylim) + 2
        }
        else {

            ## problem here: unlist loses class, important for
            ## POSIXct. Adding temporary hack as workaround, needs
            ## more thorough handling

            ## WAS: just -- y.limits <- unlist(y.limits)

            all.na <- unlist(lapply(y.limits, function(x) all(is.na(x))))
            class.ylim <- lapply(y.limits[!all.na], class) ## a list now, may be length 0
            y.limits <- unlist(y.limits)
            


            if (length(y.limits) > 0) {
                if (is.numeric(y.limits)) {
                    y.limits <- extend.limits(range(y.limits, na.rm = TRUE), axs = y.axs)
                    y.slicelen <- diff(range(y.limits))
                }
                else {
                    y.limits <- unique(y.limits[!is.na(y.limits)])
                    y.slicelen <- length(y.limits) + 2
                }
                ## put back POSIXct class (can't put back all, because 1:10 has class integer)
                if (length(class.ylim) > 0 && all(class.ylim[[1]] == c("POSIXt", "POSIXct")))
                    class(y.limits) <- c("POSIXt", "POSIXct")
            }
            else {
                y.limits <- c(0,1)
                y.slicelen <- 1
            }
        }


    else if (y.relation == "sliced") {

        if (have.ylim) {
            if (is.list(ylim)) {
                y.limits <- rep(ylim, length = nplots)
            }
            else warning("Explicitly specified x-limits ignored")
        }
        y.slicelen <- y.limits
        for (i in seq(along = y.limits))
            y.slicelen[[i]] <-
                if (is.numeric(y.limits[[i]]))
                    diff(range(y.limits[[i]])) # range unnecessary, but...
                else NA
        y.slicelen <- (if (y.axs == "i") 1 else 1.14) * max(unlist(y.slicelen), na.rm = TRUE)
        for (i in seq(along = y.limits)) {
            if (is.numeric(y.limits[[i]]))
                y.limits[[i]] <-
                    extend.limits(y.limits[[i]], length = y.slicelen)
        }
    }
    else if (y.relation == "free") {

        if (have.ylim) {
            if (!is.list(ylim)) ylim <- list(ylim)

            id <- logical(length(y.limits))
            for (i in seq(along = id)) 
                id[i] <- !any(is.na(y.limits[[i]]))
            id <- seq(along = id)[id]
            id <- id[!is.na(id)]
            
            y.limits[id] <- ylim
        }

        for (i in seq(along = y.limits)) {
            if (is.numeric(y.limits[[i]]))
                y.limits[[i]] <- extend.limits(y.limits[[i]], axs = y.axs)
            ## o.w., keep it as it is
        }
    }


    if (is.character(aspect))
        if (aspect == "xy") {
            aspect <- median(unlist(lapply(dxdy, banking)), na.rm = TRUE)
            if (y.relation == "free")
                warning("aspect=xy when y-relation=free is not sensible")
            else aspect <- aspect *
                as.numeric(
                           if (y.relation == "sliced") y.slicelen
                           else { ## i.e., relation = same
                               if (is.numeric(y.limits)) diff(y.limits)
                               else length(y.limits) + 2
                           }
                           )
            if (x.relation == "free")
                warning("aspect=xy when x-relation=free is not sensible")
            else aspect <- aspect /
                as.numeric(
                           if (x.relation == "sliced") x.slicelen
                           else {
                               if (is.numeric(x.limits)) diff(x.limits)
                               else length(x.limits) + 2
                           }
                           )
        }
    else aspect <- 1

    list(x.limits = x.limits,
         y.limits = y.limits,
         aspect.ratio = aspect)
}






trellis.skeleton <-
    function(as.table = FALSE,
             aspect = "fill",
             between = list(x=0, y=0),
             key = NULL,
             page = NULL,
             main = NULL,
             sub = NULL,
             par.strip.text = list(),
             skip = FALSE,
             strip = strip.default,
             xlab = NULL,
             ylab = NULL,
             panel = panel,
             ...)
{
    foo <- list(as.table = as.table,
                aspect.fill = aspect=="fill",
                key = key,
                panel = panel, 
                page = page,
                skip = skip,
                strip = if (is.logical(strip) && strip) "strip.default"
                else strip,
                x.between = 0,
                y.between = 0,
                par.strip.text = trellis.par.get("add.text"))
    if (is.null(foo$par.strip.text)) foo$par.strip.text = list(col = "black", cex = 1, font = 1)
    foo$par.strip.text$lines <- 1
    
    if (!is.null(between$x)) foo$x.between <- between$x
    if (!is.null(between$y)) foo$y.between <- between$y

    foo$par.strip.text[names(par.strip.text)] <- par.strip.text

    if (!is.null(main)) {
        text <- trellis.par.get("par.main.text")
        if (is.null(text)) text <- list(cex = 1.2, col = "black", font = 2) # shouldn't happen
        foo$main <- list(label = if (is.list(main)) main[[1]] else main,
                         col = text$col, cex = text$cex, font = text$font)
        if (is.list(main)) foo$main[names(main)] <- main
    }
    if (!is.null(sub)) {
        text <- trellis.par.get("par.sub.text")
        if (is.null(text)) text <- list(cex = 1, col = "black", font = 2)
        foo$sub <- list(label = if (is.list(sub)) sub[[1]] else sub,
                        col = text$col, cex = text$cex, font = text$font)
        if (is.list(sub)) foo$sub[names(sub)] <- sub
    }
    if (!is.null(xlab)) {
        text <- trellis.par.get("par.xlab.text")
        if (is.null(text)) text <- list(cex = 1, col = "black", font = 1)
        foo$xlab <- list(label = if (is.list(xlab)) xlab[[1]] else xlab,
                         col = text$col, cex = text$cex, font = text$font)
        if (is.list(xlab)) foo$xlab[names(xlab)] <- xlab
    }
    if (!is.null(ylab)) {
        text <- trellis.par.get("par.ylab.text")
        if (is.null(text)) text <- list(cex = 1.2, col = "black", font = 2)
        foo$ylab <- list(label = if (is.list(ylab)) ylab[[1]] else ylab,
                         col = text$col, cex = text$cex, font = text$font)
        if (is.list(ylab)) foo$ylab[names(ylab)] <- ylab
    }
    list(foo = foo, dots = list(...))
}







compute.layout <-
    function(layout, cond.max.level, skip = FALSE)
{
    number.of.cond <- length(cond.max.level)
    nplots <- prod(cond.max.level)
    
    if (!is.numeric(layout)) {
        layout <- c(0,1,1)
        if (number.of.cond==1) layout[2] <- nplots
        else {
            layout[1] <- cond.max.level[1]
            layout[2] <- cond.max.level[2]
        }
        skip <- rep(skip, length = max(layout[1] * layout[2], layout[2]))
        plots.per.page <- length(skip) - length(skip[skip])
        layout[3] <- ceiling(nplots/plots.per.page) # + 1
    }
    else if (length(layout)==1)
        stop("layout must have at least 2 elements")
    else if (length(layout)==2)
    {
        if(all(layout<1))
            stop("at least one element of layout must be positive")
        else if (layout[2]==0) stop("inadmissible value of layout")
        
        skip <- rep(skip, length = max(layout[1] * layout[2], layout[2]))
        plots.per.page <- length(skip) - length(skip[skip])
        layout[3] <- ceiling(nplots/plots.per.page) # + 1 
    }
    else if (length(layout)==3) {
        if(layout[1]<0||layout[2]<1||layout[3]<1)
            stop("invalid value for layout")
    }
    layout
}





### Copyright 2001  Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA









prepanel.default.densityplot <-
    function(x,
             darg,
             groups = NULL,
             subscripts = TRUE,
             ...)
{
    if (!is.numeric(x)) x <- as.numeric(x)

    if (length(x)<1)
        list(xlim = NA,
             ylim = NA,
             dx = NA,
             dy = NA)
    else if (is.null(groups))
    {
        h <- do.call("density", c(list(x=x), darg))
        list(xlim = range(h$x),
             ylim = range(h$y),
             dx = diff(h$x), dy = diff(h$y))
    }
    else
    {
        vals <- sort(unique(groups))
        nvals <- length(vals)
        xl <- numeric(0)
        yl <- numeric(0)
        dxl <- numeric(0) # bad names !!
        dyl <- numeric(0) 
        for (i in seq(along=vals)) {
            id <- (groups[subscripts] == vals[i])
            if (any(id)) {
                h <- do.call("density", c(list(x=x[id]), darg))
                xl <- c(xl, h$x)
                yl <- c(yl, h$y)
                dxl <- c(dxl, diff(h$x))
                dyl <- c(dyl, diff(h$y))
            }
        }
        list(xlim = range(xl), ylim = range(yl), dx = dxl, dy = dyl)
    }
}




panel.densityplot <-
    function(x,
             darg = list(n = 30),
             plot.points = TRUE,
             ref = FALSE,
             cex = 0.5,
             col = plot.line$col,
             col.line,
             ...)
{
    x <- as.numeric(x)

    if (ref) {
        reference.line <- trellis.par.get("reference.line")
        panel.abline(h=0,
                     col = reference.line$col,
                     lty = reference.line$lty,
                     lwd = reference.line$lwd)
    }
    if (length(x)>1) {
        plot.line <- trellis.par.get("plot.line")
        if (missing(col.line)) col.line <- col
        h <- do.call("density", c(list(x=x), darg))
        lim <- current.viewport()$xscale
        id <- (h$x>=lim[1] & h$x<=lim[2])
        llines(x = h$x[id], y = h$y[id], col = col.line, ...)
        if (plot.points) panel.xyplot(x = x, y = rep(0, length(x)), cex = cex, col = col, ...) 
    }
}





densityplot <-
    function(formula,
             data = parent.frame(),
             allow.multiple = FALSE,
             outer = FALSE,
             auto.key = FALSE,
             aspect = "fill",
             layout = NULL,
             panel = if (is.null(groups)) "panel.densityplot" else "panel.superpose",
             prepanel = NULL,
             scales = list(),
             strip = TRUE,
             groups = NULL,
             xlab,
             xlim,
             ylab,
             ylim,
             bw = NULL,
             adjust = NULL,
             kernel = NULL,
             window = NULL,
             width = NULL,
             give.Rkern = FALSE,
             n = 50,
             from = NULL,
             to = NULL,
             cut = NULL,
             na.rm = NULL,
             ...,
             panel.groups = "panel.densityplot",
             subscripts = !is.null(groups),
             subset = TRUE)
{

    ## dots <- eval(substitute(list(...)), data, parent.frame())
    dots <- list(...)

    ## darg is a list that gives arguments to density()
    darg <- list()
    darg$bw <- bw
    darg$adjust <- adjust
    darg$kernel <- kernel
    darg$window <- window
    darg$width <- width
    darg$give.Rkern <- give.Rkern
    darg$n <- n
    darg$from <- from
    darg$to <- to
    darg$cut <- cut
    darg$na.rm <- na.rm
    
    ## Step 1: Evaluate x, y, etc. and do some preprocessing
    
    groups <- eval(substitute(groups), data, parent.frame())
    subset <- eval(substitute(subset), data, parent.frame())

    formname <- deparse(substitute(formula))
    formula <- eval(substitute(formula), data, parent.frame())

    if (!inherits(formula, "formula"))
        formula <- as.formula(paste("~", formname))
    
    form <-
        latticeParseFormula(formula, data, subset = subset,
                            groups = groups, multiple = allow.multiple,
                            outer = outer, subscripts = TRUE)

    groups <- form$groups

    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)

    if ("subscripts" %in% names(formals(panel))) subscripts <- TRUE
    if (subscripts) subscr <- form$subscr

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

    cond <- form$condition
    number.of.cond <- length(cond)
    x <- form$right
    if (number.of.cond == 0) {
        strip <- FALSE
        cond <- list(as.factor(rep(1, length(x))))
        layout <- c(1,1,1)
        number.of.cond <- 1
    }

    if (missing(xlab)) xlab <- form$right.name
    if (missing(ylab)) ylab <- "Density"

    ##if (!is.numeric(x))
    ##    warning("x should be numeric")
    ##x <- as.numeric(x)

    ## create a skeleton trellis object with the
    ## less complicated components:
    foo <- do.call("trellis.skeleton",
                   c(list(aspect = aspect,
                          strip = strip,
                          panel = panel,
                          xlab = xlab,
                          ylab = ylab), dots))

    dots <- foo$dots # arguments not processed by trellis.skeleton
    foo <- foo$foo
    foo$call <- match.call()
    foo$fontsize.normal <- 10
    foo$fontsize.small <- 8

    ## This is for cases like xlab/ylab = list(cex=2)
    if (is.list(foo$xlab) && !is.characterOrExpression(foo$xlab$label))
        foo$xlab$label <- form$right.name
    if (is.list(foo$ylab) && !is.characterOrExpression(foo$ylab$label))
        foo$ylab$label <- "Density"

    ## Step 2: Compute scales.common (leaving out limits for now)

    ## scales <- eval(substitute(scales), data, parent.frame())
    if (is.character(scales)) scales <- list(relation = scales)
    foo <- c(foo,
             do.call("construct.scales", scales))


    ## Step 3: Decide if limits were specified in call:
    
    have.xlim <- !missing(xlim)
    if (!is.null(foo$x.scales$limit)) {
        have.xlim <- TRUE
        xlim <- foo$x.scales$limit
    }
    have.ylim <- !missing(ylim)
    if (!is.null(foo$y.scales$limit)) {
        have.ylim <- TRUE
        ylim <- foo$y.scales$limit
    }

    ## Step 4: Decide if log scales are being used:

    have.xlog <- !is.logical(foo$x.scales$log) || foo$x.scales$log
    have.ylog <- !is.logical(foo$y.scales$log) || foo$y.scales$log
    if (have.xlog) {
        xlog <- foo$x.scales$log
        xbase <-
            if (is.logical(xlog)) 10
            else if (is.numeric(xlog)) xlog
            else if (xlog == "e") exp(1)
        
        x <- log(x, xbase)
        if (have.xlim) xlim <- log(xlim, xbase)
    }
    if (have.ylog) {
        warning("Can't have log Y-scale")
        have.ylog <- FALSE
        foo$y.scales$log <- FALSE
    }

    ## Step 5: Process cond

    cond.max.level <- unlist(lapply(cond, nlevels))


    id.na <- is.na(x)
    for (var in cond)
        id.na <- id.na | is.na(var)
    if (!any(!id.na)) stop("nothing to draw")
    ## Nothing simpler ?

    foo$condlevels <- lapply(cond, levels)

    ## Step 6: Evaluate layout, panel.args.common and panel.args

    foo$panel.args.common <- c(dots, list(darg = darg))
    if (subscripts) {
        foo$panel.args.common$groups <- groups
        foo$panel.args.common$panel.groups <- panel.groups
    }

    layout <- compute.layout(layout, cond.max.level, skip = foo$skip)
    plots.per.page <- max(layout[1] * layout[2], layout[2])
    number.of.pages <- layout[3]
    foo$skip <- rep(foo$skip, length = plots.per.page)
    foo$layout <- layout
    nplots <- plots.per.page * number.of.pages

    foo$panel.args <- as.list(1:nplots)
    cond.current.level <- rep(1,number.of.cond)
    panel.number <- 1 # this is a counter for panel number
    for (page.number in 1:number.of.pages)
        if (!any(cond.max.level-cond.current.level<0))
            for (plot in 1:plots.per.page) {

                if (foo$skip[plot]) foo$panel.args[[panel.number]] <- FALSE
                else if(!any(cond.max.level-cond.current.level<0)) {

                    id <- !id.na
                    for(i in 1:number.of.cond)
                    {
                        var <- cond[[i]]
                        id <- id &
                        if (is.shingle(var))
                            ((var >=
                              levels(var)[[cond.current.level[i]]][1])
                             & (var <=
                                levels(var)[[cond.current.level[i]]][2]))
                        else (as.numeric(var) == cond.current.level[i])
                    }

                    foo$panel.args[[panel.number]] <-
                        list(x = x[id])
                    if (subscripts)
                        foo$panel.args[[panel.number]]$subscripts <-
                            subscr[id]

                    cond.current.level <-
                        cupdate(cond.current.level,
                                cond.max.level)
                }

                panel.number <- panel.number + 1
            }

    foo <- c(foo,
             limits.and.aspect(prepanel.default.densityplot,
                               prepanel = prepanel, 
                               have.xlim = have.xlim, xlim = xlim, 
                               have.ylim = have.ylim, ylim = ylim, 
                               x.relation = foo$x.scales$relation,
                               y.relation = foo$y.scales$relation,
                               panel.args.common = foo$panel.args.common,
                               panel.args = foo$panel.args,
                               aspect = aspect,
                               nplots = nplots,
                               x.axs = foo$x.scales$axs,
                               y.axs = foo$y.scales$axs))


    if (is.null(foo$key) && !is.null(groups) &&
        (is.list(auto.key) || (is.logical(auto.key) && auto.key)))
        foo$key <- do.call("simpleKey",
                           c(list(levels(as.factor(groups))),
                             if (is.list(auto.key)) auto.key else list()))

    class(foo) <- "trellis"
    foo
}


### Copyright 2001  Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA









prepanel.default.histogram <-
    function(x,
             breaks = NULL,
             equal.widths = TRUE,
             type = "density",
             ...)
{
    if (!is.numeric(x)) x <- as.numeric(x)

    if (length(x)<1)
        list(xlim = NA,
             ylim = NA,
             dx = NA,
             dy = NA)
    else
    {
        if (is.null(breaks)) {
            nint <- round(log2(length(x)) + 1)
            breaks <-
                if (equal.widths) do.breaks(range(x), nint)
                else quantile(x, 0:nint/nint)
        }
        h <- hist(x, breaks = breaks, plot = FALSE, ...)
        y <-
            if (type == "count") h$counts
            else if (type == "percent") 100 * h$counts/length(x)
            else h$intensities
        xlim <- range(x)
        ##lbreak <- max(xlim[1], breaks[breaks<=xlim[1]])
        ##ubreak <- min(xlim[2], breaks[breaks>=xlim[2]])
        ## why ?
        ##list(xlim = range(x, lbreak, ubreak),
        list(xlim = range(x, breaks),
             ylim = range(0,y),
             dx = 1,
             dy = 1)
    }
}









panel.histogram <- function(x,
                            breaks,
                            equal.widths = TRUE,
                            type = "density",
                            col = bar.fill$col,
                            ...)
{
    x <- as.numeric(x)

    grid.lines(x = c(0.05, 0.95),
               y = unit(c(0,0),"native"),
               default.units = "npc")
        
    if (length(x)>0) {
        bar.fill  <- trellis.par.get("bar.fill")

        if (is.null(breaks)) {

            nint <- round(log2(length(x)) + 1)
            breaks <-
                if (equal.widths) do.breaks(range(x), nint)
                else quantile(x, 0:nint/nint)

        }

        h <- hist(x, breaks = breaks, plot = FALSE, ...)
        y <-
            if (type == "count") h$counts
            else if (type == "percent") 100 * h$counts/length(x)
            else h$intensities

        nb <- length(breaks)
        if (nb != (length(y)+1)) warning("something is probably wrong")

        if (nb>1) {
            for(i in 1:(nb-1))
                if (y[i]>0) {
                    grid.rect(gp = gpar(fill = col),
                              x = breaks[i],
                              y = 0,
                              height = y[i],
                              width = breaks[i+1]-breaks[i],
                              just = c("left", "bottom"),
                              default.units = "native")
                }
        }
    }
}










histogram <-
    function(formula,
             data = parent.frame(),
             allow.multiple = FALSE,
             outer = FALSE,
             auto.key = FALSE,
             aspect = "fill",
             layout = NULL,
             panel = "panel.histogram",
             prepanel = NULL,
             scales = list(),
             strip = TRUE,
             groups = NULL,
             xlab,
             xlim,
             ylab,
             ylim,
             type = c("percent", "count", "density"),
             nint = if (is.factor(x)) length(levels(x))
             else round(log2(length(x)) + 1),
             endpoints = extend.limits(range(x[!is.na(x)]), prop = 0.04),
             breaks = if (is.factor(x)) seq(0.5, length = length(levels(x))+1)
             else do.breaks(endpoints, nint),
             equal.widths = TRUE,
             ...,
             subscripts = !is.null(groups),
             subset = TRUE)
{

    ## dots <- eval(substitute(list(...)), data, parent.frame())
    dots <- list(...)

    ## Step 1: Evaluate x, y, etc. and do some preprocessing

    groups <- eval(substitute(groups), data, parent.frame())
    subset <- eval(substitute(subset), data, parent.frame())

    formname <- deparse(substitute(formula))
    formula <- eval(substitute(formula), data, parent.frame())

    if (!inherits(formula, "formula"))
        formula <- as.formula(paste("~", formname))
    
    form <-
        latticeParseFormula(formula, data, subset = subset,
                            groups = groups, multiple = allow.multiple,
                            outer = outer, subscripts = TRUE)

    groups <- form$groups

    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)

    if ("subscripts" %in% names(formals(panel))) subscripts <- TRUE
    if (subscripts) subscr <- form$subscr

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

    cond <- form$condition
    number.of.cond <- length(cond)
    x <- form$right
    if (number.of.cond == 0) {
        strip <- FALSE
        cond <- list(as.factor(rep(1, length(x))))
        layout <- c(1,1,1)
        number.of.cond <- 1
    }






    
    if (missing(xlab)) xlab <- form$right.name
    if (missing(ylab)) ylab <- TRUE

    ##if(!(is.numeric(x) || is.factor(x)))
    ##    warning("x should be numeric")
    ##x <- as.numeric(x)
    ## create a skeleton trellis object with the
    ## less complicated components:

    foo <- do.call("trellis.skeleton",
                   c(list(aspect = aspect,
                          strip = strip,
                          panel = panel,
                          xlab = xlab,
                          ylab = ylab), dots))
                          

    dots <- foo$dots # arguments not processed by trellis.skeleton
    foo <- foo$foo
    foo$call <- match.call()
    foo$fontsize.normal <- 10
    foo$fontsize.small <- 8

    ## This is for cases like xlab/ylab = list(cex=2)
    if (is.list(foo$xlab) && !is.characterOrExpression(foo$xlab$label))
        foo$xlab$label <- form$right.name

    ## Step 2: Compute scales.common (leaving out limits for now)

    ## scales <- eval(substitute(scales), data, parent.frame())
    if (is.character(scales)) scales <- list(relation = scales)
    foo <- c(foo,
             do.call("construct.scales", scales))


    ## Step 3: Decide if limits were specified in call:
    
    have.xlim <- !missing(xlim)
    if (!is.null(foo$x.scales$limit)) {
        have.xlim <- TRUE
        xlim <- foo$x.scales$limit
    }
    have.ylim <- !missing(ylim)
    if (!is.null(foo$y.scales$limit)) {
        have.ylim <- TRUE
        ylim <- foo$y.scales$limit
    }

    ## Step 4: Decide if log scales are being used:

    have.xlog <- !is.logical(foo$x.scales$log) || foo$x.scales$log
    have.ylog <- !is.logical(foo$y.scales$log) || foo$y.scales$log
    if (have.xlog) {
        xlog <- foo$x.scales$log
        xbase <-
            if (is.logical(xlog)) 10
            else if (is.numeric(xlog)) xlog
            else if (xlog == "e") exp(1)
        
        x <- log(x, xbase)
        if (have.xlim) xlim <- log(xlim, xbase)
    }
    if (have.ylog) {
        warning("Can't have log Y-scale")
        have.ylog <- FALSE
        foo$y.scales$log <- FALSE
    }

    if ((have.xlog || is.null(breaks) ||
         length(unique(round(diff(breaks)))) != 1) &&
        missing(type))
        type <- "density"
    else type <- match.arg(type)

    if (is.logical(foo$ylab$label)) foo$ylab$label <- 
        if (type == "count") "Count"
        else if (type == "percent") "Percent of Total"
        else "Density"

    ## Step 5: Process cond

    cond.max.level <- unlist(lapply(cond, nlevels))


    id.na <- is.na(x)
    for (var in cond)
        id.na <- id.na | is.na(var)
    if (!any(!id.na)) stop("nothing to draw")
    ## Nothing simpler ?

    foo$condlevels <- lapply(cond, levels)

    ## Step 6: Evaluate layout, panel.args.common and panel.args

    ## equal.widths <- eval(equal.widths, data, parent.frame()) #keep this way ?
    foo$panel.args.common <- c(list(breaks = breaks,
                                    type = type,
                                    equal.widths = equal.widths), dots)
    if (subscripts) foo$panel.args.common$groups <- groups

    layout <- compute.layout(layout, cond.max.level, skip = foo$skip)
    plots.per.page <- max(layout[1] * layout[2], layout[2])
    number.of.pages <- layout[3]
    foo$skip <- rep(foo$skip, length = plots.per.page)
    foo$layout <- layout

    nplots <- plots.per.page * number.of.pages
    
    foo$panel.args <- as.list(1:nplots)
    cond.current.level <- rep(1,number.of.cond)
    panel.number <- 1 # this is a counter for panel number
    for (page.number in 1:number.of.pages)
        if (!any(cond.max.level-cond.current.level<0))
            for (plot in 1:plots.per.page) {

                if (foo$skip[plot]) foo$panel.args[[panel.number]] <- FALSE
                else if(!any(cond.max.level-cond.current.level<0)) {

                    id <- !id.na
                    for(i in 1:number.of.cond)
                    {
                        var <- cond[[i]]
                        id <- id &
                        if (is.shingle(var))
                            ((var >=
                              levels(var)[[cond.current.level[i]]][1])
                             & (var <=
                                levels(var)[[cond.current.level[i]]][2]))
                        else (as.numeric(var) == cond.current.level[i])
                    }

                    ##if (any(id)) {
                    foo$panel.args[[panel.number]] <-
                        list(x = x[id])
                    if (subscripts)
                        foo$panel.args[[panel.number]]$subscripts <-
                            subscr[id]
                    ##}
                    ##else
                    ##    foo$panel.args[[panel.number]] <-FALSE
                    
                    cond.current.level <-
                        cupdate(cond.current.level,
                                cond.max.level)
                }

                panel.number <- panel.number + 1
            }

    foo <- c(foo,
             limits.and.aspect(prepanel.default.histogram,
                               prepanel = prepanel, 
                               have.xlim = have.xlim, xlim = xlim, 
                               have.ylim = have.ylim, ylim = ylim, 
                               x.relation = foo$x.scales$relation,
                               y.relation = foo$y.scales$relation,
                               panel.args.common = foo$panel.args.common,
                               panel.args = foo$panel.args,
                               aspect = aspect,
                               nplots = nplots,
                               x.axs = foo$x.scales$axs,
                               y.axs = foo$y.scales$axs))


    if (is.null(foo$key) && !is.null(groups) &&
        (is.list(auto.key) || (is.logical(auto.key) && auto.key)))
        foo$key <- do.call("simpleKey",
                           c(list(levels(as.factor(groups))),
                             if (is.list(auto.key)) auto.key else list()))

    class(foo) <- "trellis"
    foo
}



### Copyright 2001-2003  Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA




prepanel.default.levelplot <-
    function(x, y, subscripts, ...)
{
    if (is.numeric(x)) {
        x <- as.numeric(x[subscripts])
        ux <- sort(unique(x[!is.na(x)]))
        xlim <-
            if (length(ux) < 2) ux + c(-1, 1)
            else c(3 * ux[1] - ux[2], 3 * ux[length(ux)] - ux[length(ux)-1])/2
    }
    else x <- x[subscripts]
    if (is.numeric(y)) {
        y <- as.numeric(y[subscripts])
        uy <- sort(unique(y[!is.na(y)]))
        ylim <-
            if (length(uy) < 2) uy + c(-1, 1)
            else c(3 * uy[1] - uy[2], 3 * uy[length(uy)] - uy[length(uy)-1])/2
    }
    else y <- y[subscripts]

    list(xlim =
         if (is.numeric(x)) extend.limits(xlim, prop = -0.0614)
         else levels(x),
         ylim = if (is.numeric(y)) extend.limits(ylim, prop = -0.0614)
         else levels(y),
         dx = if (is.numeric(x)) length(ux) else 1,
         dy = if (is.numeric(y)) length(uy) else 1)
}






panel.levelplot <-
    function(x, y, z, zcol,
             subscripts,
             at = mean(z),
             shrink,
             labels = NULL,
             label.style = c("mixed", "flat", "align"),
             contour = TRUE,
             region = TRUE,
             col = add.line$col,
             lty = add.line$lty,
             lwd = add.line$lwd,
             cex = add.text$cex,
             font = add.text$font,
             col.text = add.text$col,
             ...,
             col.regions)
{
    label.style <- match.arg(label.style)
    x <- as.numeric(x[subscripts])
    y <- as.numeric(y[subscripts])

    fullZrange <- range(as.numeric(z), na.rm = TRUE) # for shrinking
    z <- as.numeric(z[subscripts])
    zcol <- as.numeric(zcol[subscripts])

    ## Do we need a zlim-like argument ?

    shrinkx <- c(1, 1)
    shrinky <- c(1, 1)
    if (!missing(shrink)) {
        if (is.numeric(shrink)) {
            shrinkx <- rep(shrink, length = 2)
            shrinky <- rep(shrink, length = 2)
        }
        else if (is.list(shrink)) {
            shrinkx <- rep(shrink[[1]], length = 2)
            shrinky <- rep(shrink[[1]], length = 2)
            if ("x" %in% names(shrink)) shrinkx <- rep(shrink$x, length = 2)
            if ("y" %in% names(shrink)) shrinky <- rep(shrink$y, length = 2)
        }
        else warning("Invalid shrink, ignored")
    }

    scaleWidth <- function(z, min = .8, max = .8, zl = range(z, na.rm = TRUE)) {
        if (diff(zl) == 0) rep(.5 * (min + max), length(z))
        else min + (max - min) * (z - zl[1]) / diff(zl)
    }

    
    if (any(subscripts)) {

        ## sorted unique values of x 
        ux <- sort(unique(x[!is.na(x)]))
        ## actual box boundaries (x axis)
        bx <- c(3 * ux[1] - ux[2],
                ux[-length(ux)] + ux[-1],
                3 * ux[length(ux)] - ux[length(ux)-1]) / 2
        ## dimension of rectangles
        lx <- diff(bx)
        ## centers of rectangles
        cx <- (bx[-1] + bx[-length(bx)])/2

        ## same things for y
        uy <- sort(unique(y[!is.na(y)]))
        by <- c(3 * uy[1] - uy[2],
                uy[-length(uy)] + uy[-1],
                3 * uy[length(uy)] - uy[length(uy)-1]) / 2
        ly <- diff(by)
        cy <- (by[-1] + by[-length(by)])/2


        idx <- match(x, ux)
        idy <- match(y, uy)

        if (region) 
            grid.rect(x = cx[idx],
                      y = cy[idy],
                      width = lx[idx] * scaleWidth(z, shrinkx[1], shrinkx[2], fullZrange),
                      height = ly[idy] * scaleWidth(z, shrinky[1], shrinky[2], fullZrange),
                      default.units = "native",
                      gp = gpar(fill=col.regions[zcol], col = NULL))


        ################################################
#         dux <- diff(ux)
#         wux <- .5 * (c(dux[1], dux) + c(dux, dux[length(dux)]))
#         ##wx <- wux[match(x[!is.na(x)], ux)]
#         wx <- wux[match(x, ux)]
#         uy <- sort(unique(y[!is.na(y)]))
#         duy <- diff(uy)
#         wuy <- .5 * (c(duy[1], duy) + c(duy, duy[length(duy)]))
#         ##wy <- wuy[match(y[!is.na(y)], uy)]
#         wy <- wuy[match(y, uy)]

#         if (region) {
#             for (i in seq(along = col.regions)) {
#                 ok <- (zcol[subscripts]==i)
#                 if (any(ok))
#                     grid.rect(x = x[ok],
#                               y = y[ok],
#                               width = wx[ok],
#                               height = wy[ok],
#                               default.units = "native",
#                               gp = gpar(fill=col.regions[i], col = NULL))
#             }
#         }
        ################################################


        
        if (contour) {


            ## FIXME:

            ## bad hack for when z contains NA's. Including anyway
            ## since the result would be much worse without it (well,
            ## that at least had the advantage of being obviously
            ## broken, as opposed to this which will in certain cases
            ## silently give the wrong result... still, shouldn't be
            ## that bad)

            ## z[is.na(z)] <- min(z, na.rm = TRUE)



            add.line <- trellis.par.get("add.line")
            add.text <- trellis.par.get("add.text")
            ux <- as.double(ux)
            uy <- as.double(uy)
            ord <- order(x, y)
            m <- z[ord] + 10e-12 ## some problems otherwise
            
            for (i in seq(along = at)) {
                val <- .Call("calculateContours", m, ux, uy, as.double(at[i]),
                             length(ux), length(uy), PACKAGE="lattice")
                if (length(val[[1]]) > 3) {
                    if (is.null(labels))
                        lsegments(val[[1]], val[[2]], val[[3]], val[[4]],
                                  col = col, lty = lty, lwd = lwd)
                    else {

                        if (label.style == "flat") {
                            slopes <-
                                (val[[4]] - val[[2]]) /
                                    (val[[3]] - val[[1]])
                            textloc <- which(abs(slopes) == min(abs(slopes)))[1]
                            ##skiploc <- numeric(0)
                            rotangle <- 0
                        }
                        else if (label.style == "align") {
                            rx <- range(ux)
                            ry <- range(uy)
                            depth <- pmin( (val[[1]] + val[[3]] - 2 * rx[1])/diff(rx),
                                          (2 * rx[2] - val[[1]] - val[[3]])/diff(rx),
                                          (val[[2]] + val[[4]] - 2 * ry[1])/diff(ry),
                                          (2 * ry[2] - val[[2]] - val[[4]])/diff(ry))
                            textloc <- which(depth == max(depth))[1]
                            slopes <-
                                (val[[4]][textloc] - val[[2]][textloc]) /
                                    (val[[3]][textloc] - val[[1]][textloc])
                            rotangle <- atan(slopes * diff(rx) / diff(ry)) * 180 / base::pi
                        }
                        else if (label.style == "mixed") {
                            slopes <-
                                (val[[4]] - val[[2]]) /
                                    (val[[3]] - val[[1]])
                            rx <- range(ux)
                            ry <- range(uy)
                            depth <- pmin( (val[[1]] + val[[3]] - 2 * rx[1])/diff(rx),
                                          (2 * rx[2] - val[[1]] - val[[3]])/diff(rx),
                                          (val[[2]] + val[[4]] - 2 * ry[1])/diff(ry),
                                          (2 * ry[2] - val[[2]] - val[[4]])/diff(ry))

                            textloc <- which(abs(slopes) == min(abs(slopes), na.rm = TRUE))[1]
                            rotangle <- 0

                            if ( depth[textloc] < .05 ) {
                                textloc <- which(depth == max(depth))[1]
                                rotangle <- atan(slopes[textloc] * diff(rx) / diff(ry)) * 180 / base::pi
                            }
                        }
                        else stop("Invalid label.style")

                        lsegments(val[[1]], val[[2]],
                                  val[[3]], val[[4]],
                                  col = col, lty = lty, lwd = lwd)

                        ltext(lab = labels$lab[i], adj = c(.5, 0),
                              srt = rotangle,
                              col = col.text, cex = cex, font = font,
                              x = .5 * (val[[1]][textloc]+val[[3]][textloc]),
                              y = .5 * (val[[2]][textloc]+val[[4]][textloc]))

                    }
                }
            }
        }
    }
}









contourplot <-
    function(formula,
             data = parent.frame(),
             panel = "panel.levelplot",
             prepanel = NULL,
             strip = TRUE,
             groups = NULL,
             cuts = 7,
             labels = TRUE,
             contour = TRUE,
             pretty = TRUE,
             region = FALSE,
             ...,
             subset = TRUE)

{
    ## m <- match.call(expand.dots = FALSE)
    dots <- list(...)
    groups <- eval(substitute(groups), data, parent.frame())
    subset <- eval(substitute(subset), data, parent.frame())

    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)

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

    do.call("levelplot",
            c(list(formula = formula,
                   data = data,
                   groups = groups,
                   subset = subset,
                   panel = panel,
                   prepanel = prepanel,
                   strip = strip,
                   labels = labels,
                   cuts = cuts,
                   contour = contour,
                   pretty = pretty,
                   region = region),
              dots))
}







levelplot <-
    function(formula,
             data = parent.frame(),
             aspect = "fill",
             layout = NULL,
             panel = "panel.levelplot",
             prepanel = NULL,
             scales = list(),
             strip = TRUE,
             groups = NULL,
             xlab,
             xlim,
             ylab,
             ylim,
             at,
             contour = FALSE,
             cuts = 15,
             labels = FALSE,
             pretty = FALSE,
             region = TRUE,
             ...,
             colorkey = region,
             col.regions = trellis.par.get("regions")$col,
             subscripts = TRUE,
             subset = TRUE)
{

    ##dots <- eval(substitute(list(...)), data, parent.frame())
    dots <- list(...)

    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)

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

    ## Step 1: Evaluate x, y, z etc. and do some preprocessing

    formula <- eval(substitute(formula), data, parent.frame())
    form <-
        if (inherits(formula, "formula"))
            latticeParseFormula(formula, data, dim = 3)
        else {
            if (is.matrix(formula)) {
                tmp <- expand.grid(1:nrow(formula), 1:ncol(formula))
                list(left = as.vector(formula),
                     right.x = tmp[[1]],
                     right.y = tmp[[2]],
                     condition = NULL,
                     left.name = "",
                     right.x.name = "", right.y.name = "")
            }
            else if (is.data.frame(formula)) {
                tmp <- expand.grid(rownames(formula), colnames(formula))
                list(left = as.vector(as.matrix(formula)),
                     right.x = tmp[[1]],
                     right.y = tmp[[2]],
                     condition = NULL,
                     left.name = "",
                     right.x.name = "", right.y.name = "")
            }
            else stop("invalid formula")
        }

    cond <- form$condition
    number.of.cond <- length(cond)
    z <- form$left
    x <- form$right.x
    y <- form$right.y

    if (number.of.cond == 0) {
        strip <- FALSE
        cond <- list(as.factor(rep(1, length(x))))
        layout <- c(1,1,1)
        number.of.cond <- 1
    }
    groups <- eval(substitute(groups), data, parent.frame())
    subset <- eval(substitute(subset), data, parent.frame())
    subscr <- seq(along=x)
    x <- x[subset, drop = TRUE]
    y <- y[subset, drop = TRUE]
    z <- z[subset, drop = TRUE]
    subscr <- subscr[subset, drop = TRUE]

    if (missing(xlab)) xlab <- form$right.x.name
    if (missing(ylab)) ylab <- form$right.y.name

    #if(!(is.numeric(x) && is.numeric(y) && is.numeric(z)))
    #    warning("x, y and z should be numeric")
    #x <- as.numeric(x)
    #y <- as.numeric(y)
    #z <- as.numeric(z)

    zrng <- extend.limits(range(z[!is.na(z)]))
    if (missing(at))
        at <-
            if (pretty) lpretty(zrng, cuts)
            else seq(zrng[1], zrng[2], length = cuts+2)
    

    ## create a skeleton trellis object with the
    ## less complicated components:

    foo <- do.call("trellis.skeleton",
                   c(list(aspect = aspect,
                          strip = strip,
                          panel = panel,
                          xlab = xlab,
                          ylab = ylab), dots))
                          

    ## Processing the labels argument
    if (is.logical(labels) && !labels) labels <- NULL
    else {
        if (is.logical(labels)) labels <- format(at)
        text <- trellis.par.get("add.text") # something better ?
        if (is.null(text)) text <- list(cex = 1, col = "black", font = 1, rot = 0)
        labels <- list(label = if (is.list(labels)) labels[[1]] else labels,
                       col = text$col, rot = text$rot,
                       cex = text$cex, font = text$font)
        if (is.list(labels)) labels[names(labels)] <- labels
        if (!is.characterOrExpression(labels$label))
            labels$label <- format(at)
    }

    
    dots <- foo$dots # arguments not processed by trellis.skeleton
    foo <- foo$foo
    foo$call <- match.call()
    foo$fontsize.normal <- 10
    foo$fontsize.small <- 8

    ## This is for cases like xlab/ylab = list(cex=2)
    if (is.list(foo$xlab) && !is.characterOrExpression(foo$xlab$label))
        foo$xlab$label <- form$right.name
    if (is.list(foo$ylab) && !is.characterOrExpression(foo$ylab$label))
        foo$ylab$label <- form$left.name

    ## Step 2: Compute scales.common (excluding limits)

    ## scales <- eval(substitute(scales), data, parent.frame())
    if (is.character (scales)) scales <- list(relation = scales)
    foo <- c(foo,
             do.call("construct.scales", scales))


    ## Step 3: Decide if limits were specified in call:

    have.xlim <- !missing(xlim)
    if (!is.null(foo$x.scales$limit)) {
        have.xlim <- TRUE
        xlim <- foo$x.scales$limit
    }
    have.ylim <- !missing(ylim)
    if (!is.null(foo$y.scales$limit)) {
        have.ylim <- TRUE
        ylim <- foo$y.scales$limit
    }

    ## Step 4: Decide if log scales are being used:

    have.xlog <- !is.logical(foo$x.scales$log) || foo$x.scales$log
    have.ylog <- !is.logical(foo$y.scales$log) || foo$y.scales$log
    if (have.xlog) {
        xlog <- foo$x.scales$log
        xbase <-
            if (is.logical(xlog)) 10
            else if (is.numeric(xlog)) xlog
            else if (xlog == "e") exp(1)

        x <- log(x, xbase)
        if (have.xlim) xlim <- log(xlim, xbase)
    }
    if (have.ylog) {
        ylog <- foo$y.scales$log
        ybase <-
            if (is.logical(ylog)) 10
            else if (is.numeric(ylog)) ylog
            else if (ylog == "e") exp(1)

        y <- log(y, ybase)
        if (have.ylim) ylim <- log(ylim, ybase)
    }
    
    ## Step 5: Process cond

    cond <- lapply(cond, as.factorOrShingle, subset, drop = TRUE)
    cond.max.level <- unlist(lapply(cond, nlevels))

    id.na <- is.na(x)|is.na(y)  ##|is.na(z)
    for (var in cond)
        id.na <- id.na | is.na(var)
    if (!any(!id.na)) stop("nothing to draw")
    ## Nothing simpler ?

    foo$condlevels <- lapply(cond, levels)

    ## Step 6: Evaluate layout, panel.args.common and panel.args

    ## Most levelplot/contourplot specific code here


    ## region
    numcol <- length(at)-1
    numcol.r <- length(col.regions)

    col.regions <-
        if (numcol.r <= numcol)
            rep(col.regions, length = numcol)
        else col.regions[floor(1+(1:numcol-1)*(numcol.r-1)/(numcol-1))]
    
    if (is.logical(colorkey)) {
        if (colorkey) foo$colorkey <-
            list(space = "right", col = col.regions,
                 at = at, tick.number = 7)
    }
    else if (is.list(colorkey)) {
        foo$colorkey <- colorkey
        if (is.null(foo$colorkey$col)) foo$colorkey$col <- col.regions
        if (is.null(foo$colorkey$at)) foo$colorkey$at <- at
    }

    ## Current algo unnecessarily memory intensive ?

    
    
    ## I'm going to create vectors parallel to x y etc which would
    ## give the widths and heights of the rectangles for each point.
    ## My algo works only when the x's and y's are really evaluated
    ## on a grid, that is, there is no numerical error. Splus also
    ## doesn't work (in any meaningful way, at least) in such cases,
    ## but behaviour would be dissimilar in that case.

#     ux <- sort(unique(x[!is.na(x)]))
#     dux <- diff(ux)
#     wux <- .5 * (c(dux[1], dux) + c(dux, dux[length(dux)]))
#     ##wx <- wux[match(x[!is.na(x)], ux)]
#     wx <- wux[match(x, ux)]
#     uy <- sort(unique(y[!is.na(y)]))
#     duy <- diff(uy)

# print(uy)

#     wuy <- .5 * (c(duy[1], duy) + c(duy, duy[length(duy)]))
#     ##wy <- wuy[match(y[!is.na(y)], uy)]
#     wy <- wuy[match(y, uy)]

    zcol <- rep(NA, length(z)) #numeric(length(z))
    for (i in seq(along=col.regions))
        zcol[!id.na & !is.na(z) & z>=at[i] & z<at[i+1]] <- i

    foo$panel.args.common <-
        c(list(x=x, y=y, z=z, at=at, labels=labels,
               region = region, contour = contour,
               zcol=zcol, col.regions=col.regions),
          dots)

    if (!is.null(groups)) foo$panel.args.common$groups <- groups

    layout <- compute.layout(layout, cond.max.level, skip = foo$skip)
    plots.per.page <- max(layout[1] * layout[2], layout[2])
    number.of.pages <- layout[3]
    foo$skip <- rep(foo$skip, length = plots.per.page)
    foo$layout <- layout
    nplots <- plots.per.page * number.of.pages

    foo$panel.args <- as.list(1:nplots)
    cond.current.level <- rep(1, number.of.cond)
    panel.number <- 1 # this is a counter for panel number

    for (page.number in 1:number.of.pages)
        if (!any(cond.max.level-cond.current.level<0))
            for (plot in 1:plots.per.page) {

                if (foo$skip[plot]) foo$panel.args[[panel.number]] <- FALSE
                else if(!any(cond.max.level-cond.current.level<0)) {

                    id <- !id.na
                    for(i in 1:number.of.cond)
                    {
                        var <- cond[[i]]
                        id <- id &
                        if (is.shingle(var))
                            ((var >=
                              levels(var)[[cond.current.level[i]]][1])
                             & (var <=
                                levels(var)[[cond.current.level[i]]][2]))
                        else (as.numeric(var) == cond.current.level[i])
                    }

                    foo$panel.args[[panel.number]] <- 
                        list(subscripts = subscr[id])

                    cond.current.level <-
                        cupdate(cond.current.level,
                                cond.max.level)
                }

                panel.number <- panel.number + 1
            }

    foo <- c(foo,
             limits.and.aspect(prepanel.default.levelplot,
                               prepanel = prepanel, 
                               have.xlim = have.xlim, xlim = xlim, 
                               have.ylim = have.ylim, ylim = ylim, 
                               x.relation = foo$x.scales$relation,
                               y.relation = foo$y.scales$relation,
                               panel.args.common = foo$panel.args.common,
                               panel.args = foo$panel.args,
                               aspect = aspect,
                               nplots = nplots,
                               x.axs = foo$x.scales$axs,
                               y.axs = foo$y.scales$axs))

    class(foo) <- "trellis"
    foo
}











### Copyright 2001-2003 Deepayan Sarkar <deepayan@stat.wisc.edu> and 
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


lpretty <- function(x, ...) { 
    eps <- 1e-10
    at <- pretty(x[is.finite(x)], ...)
    at <- ifelse(abs(at-round(at, 3))<eps, round(at, 3), at)
}


oneway <-
    function(formula, data, location = mean,
             spread = function(x) sqrt(var(x)))
{
    if(missing(data)) data <- sys.frame(sys.parent())
    form <- latticeParseFormula(formula, data)
    y <- form$left
    x <- form$right
    if (!is.shingle(x)) x <- as.factor(x)
    is.f.x <- is.factor(x)
    num.l.x <- nlevels(x) 
    foo <- list()
    if (is.f.x) {
        foo$location <-
            if (is.function(location)) as.vector(tapply(X=y, INDEX=list(x), FUN = location))
            else rep(location, num.l.x)
        foo$spread <- 
            if (is.function(spread)) as.vector(tapply(X=y, INDEX=list(x), FUN = spread))
            else rep(spread, num.l.x)
        foo$fitted.values <- numeric(length(y))
        sc <- numeric(length(y))
        for (i in seq(along = y)){
            foo$fitted.values[i] <- foo$location[as.numeric(x)[i]]
            sc[i] <- foo$spread[as.numeric(x)[i]]
        }
        foo$residuals <- y - foo$fitted.values
        foo$scaled.residuals <- foo$residuals/sc
    }
    else stop("x must be (coercible to be) a factor")
    foo
}


do.breaks  <- function(endpoints, nint)
{
    if (length(endpoints)!=2) stop("error")
    endpoints[1] + diff(endpoints) * 0:nint / nint
}


is.characterOrExpression <- function(x)
    is.character(x) || is.expression(x)




## This converts character to factor, numeric to shingle, and
## in addition, takes subsets
as.factorOrShingle <- function(x, subset = TRUE, drop = FALSE)
{
    x <-
        if (is.numeric(x))
            as.shingle(x)
        else ##if (is.character(x)) or logical or ??
            as.factor(x)
    x[subset, drop = drop]
}



"[.shingle" <-
    function(x, subset, drop = FALSE)
{
    if (!is.shingle(x)) stop("x must be a shingle")
    ans <- as.numeric(x)[subset]
    attr(ans, "levels") <- levels(x)
    class(attr(ans, "levels")) <- "shingleLevel"
    if (drop) {
        xlvs <- levels(ans)
        dl <- logical(nlevels(ans))
        for (i in seq(along=dl))
            dl[i] <- any( ans >= xlvs[[i]][1] & ans <= xlvs[[i]][2] )
        attr(ans, "levels") <- xlvs[dl]
        class(attr(ans, "levels")) <- "shingleLevel"
    }
    class(ans) <- "shingle"
    ans
}



Rows <- function(x, which)
{
    for (i in seq(along = x)) x[[i]] <- x[[i]][which]
    x
}
## S-Plus trellis function needed for nlme.



make.list.from.intervals <- function(x)
{
    if (ncol(x)!=2) stop("x must be matrix with 2 columns")
    if (nrow(x)<1) stop("x must be matrix with at least 1 row")
    ans <- as.list(1:nrow(x))
    for (i in 1:nrow(x))
        ans[[i]] <- x[i,]
    ans
}



equal.count <-
  function(x, ...)
{
    attr(x, "levels") <- make.list.from.intervals(co.intervals(x,...))
    class(attr(x, "levels")) <- "shingleLevel"
    class(x) <- "shingle"
    x
}



shingle <-
    function(x, intervals=sort(unique(x)))
{
    if (ncol(as.matrix(intervals))==1)
        intervals <- cbind(intervals, intervals)
    else if (ncol(as.matrix(intervals)) > 2)
        stop("bad value of 'intervals'")
    attr(x, "levels") <- make.list.from.intervals(intervals)
    class(attr(x, "levels")) <- "shingleLevel"
    class(x) <- "shingle"
    x
}


as.data.frame.shingle <- as.data.frame.factor

is.shingle <-
    function(x) inherits(x, "shingle")


as.shingle <-
    function(x) if (is.shingle(x)) x else shingle(x)



summary.shingle <- function(object, ...) print.shingle(object, ...)


print.shingleLevel <-
    function(x, ...) {
        print(do.call("rbind", x))
        invisible(x)
    }

print.shingle <- function(x, showValues = TRUE, ...) {
    cat("\nData:\n")
    if (showValues) print(as.numeric(x))
    l <- levels(x)
    n <- nlevels(x)
    if (n<1) cat("\nno intervals\n")
    else {
        int <- data.frame(min = numeric(n), max = numeric(n), count = numeric(n))
        for (i in 1:n) {
            int$min[i] <- l[[i]][1]
            int$max[i] <- l[[i]][2]
            int$count[i] <- length(x[x>=l[[i]][1] & x<=l[[i]][2]])
        }
        cat("\nIntervals:\n")
        print(int)
        olap <- numeric(n-1)
        if (n>2)
            for (i in 1:(n-1))
                olap[i] <- length(x[ x>=l[[i]][1] & x<=l[[i]][2] &
                                    x>=l[[i+1]][1] & x<=l[[i+1]][2]])
        cat("\nOvrlap between adjacent intervals:\n")
        print(olap)
    }
    invisible(x)
}





strip.default <-
    function(which.given,
             which.panel,
             var.name,
             factor.levels,
             shingle.intervals,
             strip.names = c(FALSE, TRUE),
             style = 1,
             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"))
{
    default.fontsize <- trellis.par.get("fontsize")$default
    name <- var.name[which.given]
    level <- which.panel[which.given]
    strip.names <- rep(strip.names, length = 2)
    
    if (is.null(factor.levels)) { # means this is a  shingle, as opposed to a factor
        if (is.null(shingle.intervals)) stop("both factor.levels and shingle.intervals cannot be NULL")
        strip.names <- strip.names[2]
        grid.rect(gp = gpar(fill=bg))
        t <- range(shingle.intervals)
        r <- (range(shingle.intervals[level,])-t[1])/diff(t)
        grid.rect(x = unit(r%*%c(.5,.5),"npc"), width = max(unit( c(diff(r), 1), c("npc", "mm"))),
                  gp = gpar(col=fg, fill=fg))
        if (strip.names)
            grid.text(label = name,
                      gp = gpar(col = par.strip.text$col,
                      font = par.strip.text$font,
                      fontsize = par.strip.text$cex *
                      default.fontsize))
        grid.rect()
    }
    else if (is.null(shingle.intervals)) { # factor
        strip.names <- strip.names[1]
        x <- factor.levels
        num <- length(x)
        if (style == 1) {
            grid.rect(gp = gpar(fill=bg))
            if (strip.names) {
                grid.text(name,
                          x=unit(0.5, "npc") - unit(1, "mm"),
                          gp = gpar(col = par.strip.text$col,
                          font = par.strip.text$font,
                          fontsize = par.strip.text$cex *
                          default.fontsize),
                          just="right")
                grid.text(":",
                          x=unit(0.5, "npc"),
                          gp = gpar(col = par.strip.text$col,
                          font = par.strip.text$font,
                          fontsize = par.strip.text$cex *
                          default.fontsize))
                grid.text(x[level],
                          x=unit(0.5, "npc") + unit(1, "mm"),
                          gp = gpar(col = par.strip.text$col,
                          font = par.strip.text$font,
                          fontsize = par.strip.text$cex *
                          default.fontsize),
                          just="left")
            }
            else grid.text(label = x[level],
                           gp = gpar(col = par.strip.text$col,
                           font = par.strip.text$font,
                           fontsize = par.strip.text$cex *
                           default.fontsize))
            grid.rect()
        }
        else if (style == 2) {
            grid.rect(x = unit((2*level-1)/(2*num), "npc"),
                      width = unit(1/num, "npc"),
                      gp = gpar(fill=fg, col = NULL))
            grid.text(label=x,
                      x = (2*1:num-1)/(2*num),
                      gp = gpar(col = par.strip.text$col,
                      font = par.strip.text$font,
                      fontsize = par.strip.text$cex *
                      default.fontsize))
            grid.rect()
        }
        else if (style == 3){
            grid.rect(gp = gpar(fill=bg))
            grid.rect(x = unit((2*level-1)/(2*num), "npc"),
                      width = unit(1/num, "npc"),
                      gp = gpar(fill=fg, col = NULL))
            grid.text(label =
                      if (strip.names) paste(name, x[level], sep = ": ")
                      else x[level],
                      gp = gpar(col = par.strip.text$col, 
                      font = par.strip.text$font,
                      fontsize = par.strip.text$cex *
                      default.fontsize))
            grid.rect()
        }
        else if(style == 4){
            grid.rect(gp = gpar(fill=bg))
            grid.rect(x = unit((2*level-1)/(2*num), "npc"),
                      width = unit(1/num, "npc"),
                      gp = gpar(col=NULL, fill=fg))
            grid.text(label=x,
                      x = (2* 1:num - 1)/(2*num),   #using default.units
                      gp = gpar(col = par.strip.text$col, 
                      font = par.strip.text$font,
                      fontsize = par.strip.text$cex *
                      default.fontsize))
            grid.rect()
        }
        else if(style >= 5){
            grid.rect(gp = gpar(fill=bg))
            grid.text(label=x[level],
                      x = (2* level - 1)/(2*num),   #using default.units
                      gp = gpar(col = par.strip.text$col, 
                      font = par.strip.text$font,
                      fontsize = par.strip.text$cex *
                      default.fontsize))
            grid.rect()
        }
    }
}







lsegments <-
    function(x0 = NULL, y0 = NULL, x1, y1, x2 = NULL, y2 = NULL,
             col = add.line$col,
             lty = add.line$lty,
             lwd = add.line$lwd, ...)
{
    if (missing(x0)) x0 <- x2
    if (missing(y0)) y0 <- y2
    add.line <- trellis.par.get("add.line")
    ml <- max(length(x0), length(x1), length(y0), length(y1))
    x0 <- rep(x0, length = ml)
    x1 <- rep(x1, length = ml)
    y0 <- rep(y0, length = ml)
    y1 <- rep(y1, length = ml)

    grid.segments(x0 = x0, x1 = x1,
                  y0 = y0, y1 = y1,
                  gp = gpar(lty=lty,
                  col=col, lwd=lwd),
                  default.units="native")
}


larrows <-
    function(x0 = NULL, y0 = NULL, x1, y1, x2 = NULL, y2 = NULL,
             angle = 30, code = 2, length = NULL, proportion = .05, ...) 
{

    if (missing(x0)) {x0 <- x1; x1 <- x2}
    if (missing(y0)) {y0 <- y1; y1 <- y2}
    if (!is.null(length)) warning("length not implemented in larrows, use proportion instead")

    angle <- angle / 180 * pi
    start <- rbind(x0, y0)
    end <- rbind(x1, y1)
    v.forward <- end - start
    v.backward <- start - end
    lsegments(x0, y0, x1, y1, ...)
    
    if (code %in% c(1,3)) { # arrow at starting point
        edge.1 <- proportion * 
            matrix( c(cos(angle), -sin(angle), sin(angle), cos(angle)), 2, 2) %*% v.forward
        edge.2 <- proportion *
            matrix( c(cos(-angle), -sin(-angle), sin(-angle), cos(-angle)), 2, 2) %*% v.forward
        lsegments(x0, y0, x0 + edge.1[1,], y0 + edge.1[2,], ...)
        lsegments(x0, y0, x0 + edge.2[1,], y0 + edge.2[2,], ...)
    }
    if (code %in% c(2,3)) { # arrow at ending point
        edge.1 <- proportion * 
            matrix( c(cos(angle), -sin(angle), sin(angle), cos(angle)), 2, 2) %*% v.backward
        edge.2 <- proportion *
            matrix( c(cos(-angle), -sin(-angle), sin(-angle), cos(-angle)), 2, 2) %*% v.backward
        lsegments(x1, y1, x1 + edge.1[1,], y1 + edge.1[2,], ...)
        lsegments(x1, y1, x1 + edge.2[1,], y1 + edge.2[2,], ...)
    }
}



ltext <-
    function(x, y = NULL, labels = seq(along = x),
             col = add.text$col,
             cex = add.text$cex,
             srt = 0,
             font = 1,
             adj = c(.5, .5),
             pos,
             ...)
{
    add.text <- trellis.par.get("add.text")
    xy <- xy.coords(x, y)
    if (!missing(pos))
        adj <-
            if (pos == 1) c(.5, 1)
            else if (pos == 2) c(1, .5)
            else if (pos == 3) c(.5, 0)
            else if (pos == 4) c(0, .5)
    if (length(adj) == 1) adj <- c(adj, .5)
    grid.text(label = labels, x = xy$x, y = xy$y,
              gp = gpar(col = col, font = font,
              fontsize = cex * trellis.par.get("fontsize")$default),
              just = c(if (adj[1] == 0) "left"
              else if (adj[1] == 1) c("right")
              else "centre",
              if (adj[2] == 0) "bottom"
              else if (adj[2] == 1) c("top")
              else "centre"),
              rot = srt,
              default.units = "native")
}





llines <-
    function(x, y = NULL, type = "l",
             col = plot.line$col,
             lty = plot.line$lty,
             lwd = plot.line$lwd, ...)
{
    plot.line <- trellis.par.get("plot.line")
    lplot.xy(xy.coords(x, y), type = type,
             col = col, lty = lty, lwd = lwd, ...)
}




lpoints <-
    function(x, y = NULL, type = "p",
             col = plot.symbol$col,
             pch = plot.symbol$pch,
             cex = plot.symbol$cex, ...)
{
    plot.symbol <- trellis.par.get("plot.symbol")
    lplot.xy(xy.coords(x, y), type = type,
             col = col, pch = pch, cex = cex, ...)
}






lplot.xy <-
    function(xy, type, pch = 1, lty = 1, col = 1, cex = 1, lwd = 1, font = 1, ...)

    ## currently uses grid.text for non-numeric pch. This would allow
    ## pch like pch = 'string' or pch = expression(sigma). This
    ## feature would disappear in the future.

{
    x <- xy$x
    y <- xy$y

    if (type %in% c("l", "o", "b", "c"))
        grid.lines(x=x, y=y, gp = gpar(lty=lty, col=col, lwd=lwd),
                   default.units="native")
    
    if (type %in% c("p", "o", "b", "c"))

        if (is.numeric(pch))
            grid.points(x = x, y = y, size = unit(cex * 2.5, "mm"),
                    gp = gpar(col = col), #, cex = cex),
                    pch = pch, 
                    default.units="native")
        else
            grid.points(x = x, y = y, 
                    gp = gpar(col = col, cex = cex),
                    pch = pch, 
                    default.units="native")


            #grid.text(label = pch, x = x, y = y,
            #          gp = gpar(col = col, fontsize = cex * trellis.par.get("fontsize")$default),
            #          default.units = "native")

    if (type %in% c("s", "S")) {
        ord <- sort.list(x)
        n <- length(x)
        xx <- numeric(2*n-1)
        yy <- numeric(2*n-1)

        xx[2*1:n-1] <- x[ord]
        yy[2*1:n-1] <- y[ord]
        xx[2*1:(n-1)] <- x[ord][if (type=="s") -1 else -n]
        yy[2*1:(n-1)] <- y[ord][if (type=="s") -n else -1]
        grid.lines(x=xx, y=yy,
                   gp = gpar(lty=lty, col=col, lwd=lwd),
                   default.units="native")
    }

    if (type == "h") {

        ylim <- current.viewport()$yscale

        zero <-
            if (ylim[1] > 0) ylim[1]
            else if (ylim[2] < 0) ylim[2]
            else 0

        ##print(zero) ?
        ##print(x) 
        for (i in seq(along=x))
            grid.lines(x=rep(x[i],2), y=c(y[i], zero),
                       gp = gpar(lty=lty, col=col, lwd=lwd),
                       default.units="native")
    }
}










### Copyright 2001  Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

## the foll functions don't do much error checking yet



panel.abline <-
    function(a, b = NULL, h = numeric(0), v = numeric(0),
             col, col.line = add.line$col, lty = add.line$lty,
             lwd = add.line$lwd, ...)
{
    add.line <- trellis.par.get("add.line")
    if (!missing(col)) {
        if (missing(col.line)) col.line <- col
    }
    
    if (!missing(a)) {
        if (inherits(a,"lm")) {
            coeff <- coef(a)
        }
        else if (!is.null(coef(a))) coeff <- coef(a)  # ????
        else coeff <- c(a,b)

        if (length(coeff)==1) coeff <- c(0, coeff)
        
        if (coeff[2]==0) h <- c(h, coeff[1])
        else if (!any(is.null(coeff))) {
            xx <- current.viewport()$xscale
            yy <- current.viewport()$yscale
            
            x <- numeric(0)
            y <- numeric(0)
            ll <- function(i, j, k, l)
                (yy[j]-coeff[1]-coeff[2]*xx[i]) *
                    (yy[l]-coeff[1]-coeff[2]*xx[k])
            
            if (ll(1,1,2,1)<=0) {
                y <- c(y, yy[1])
                x <- c(x, (yy[1]-coeff[1])/coeff[2])
            }
            
            if (ll(2,1,2,2)<=0) {
                x <- c(x, xx[2])
                y <- c(y, coeff[1] + coeff[2] * xx[2])
            }
            
            if (ll(2,2,1,2)<=0) {
                y <- c(y, yy[2])
                x <- c(x, (yy[2]-coeff[1])/coeff[2])
            }
            
            if (ll(1,2,1,1)<=0) {
                x <- c(x, xx[1])
                y <- c(y, coeff[1] + coeff[2] * xx[1])
            }
            
            if (length(x)>0)
                grid.lines(x=x, y = y, default.units="native",
                           gp = gpar(col=col.line, lty=lty, lwd=lwd))
        }
    }
    
    h <- as.numeric(h)
    v <- as.numeric(v)
    
    for(i in seq(along=h))
        grid.lines(y=rep(h[i],2), default.units="native", gp = gpar(col=col.line,lty=lty,lwd=lwd))

    for(i in seq(along=v))
        grid.lines(x=rep(v[i],2), default.units="native", gp = gpar(col=col.line,lty=lty,lwd=lwd))
    
}




panel.curve <-
    function (expr, from, to, n = 101,
              curve.type = "l",
              col = add.line$col,
              lty = add.line$lty,
              lwd = add.line$lwd,
              type = NULL, ## avoid type meant for panel.xyplot etc
              ...)
    ## curve has a log option. Unfortunately there is no easy way to
    ## read in the lattice log options (specified via scales) into the
    ## panel function. Maybe some day if grid natively supports log
    ## scales and lattice is redesigned to take advantage of that
{
    add.line <- trellis.par.get("add.line")
    sexpr <- substitute(expr)
    if (is.name(sexpr)) {
        fcall <- paste(sexpr, "(x)")
        expr <- parse(text = fcall)
    }
    else {
        if (!(is.call(sexpr) && match("x", all.vars(sexpr), nomatch = 0))) 
            stop("'expr' must be a function or an expression containing 'x'")
        expr <- sexpr
    }
    lims <- current.viewport()$xscale
    if (missing(from)) 
        from <- lims[1]
    if (missing(to)) 
        to <- lims[2]
    x <- seq(from, to, length = n)
    y <- eval(expr, envir = list(x = x), enclos = parent.frame())
    llines(x, y, type = curve.type, col = col, lty = lty, lwd = lwd, ...)
}





panel.fill <-
    function(col = trellis.par.get("background")$col, ...)
{
    grid.rect(gp=gpar(fill=col))
}












panel.grid <-
    function(h = 3, v = 3,
             col, col.line = reference.line$col,
             lty = reference.line$lty,
             lwd = reference.line$lwd, ...)
{
    reference.line <- trellis.par.get("reference.line")
    if (!missing(col)) {
        if (missing(col.line)) col.line <- col
    }

    if (h>0)
        for(i in 1:h)
            grid.lines(y=rep(i/(h+1),2),
                       gp = gpar(col = col.line, lty = lty, lwd = lwd),
                       default.units="npc")

    if (v>0)
        for(i in 1:v)
            grid.lines(x=rep(i/(v+1),2),
                       gp = gpar(col = col.line, lty = lty, lwd = lwd),
                       default.units="npc")


    ## Cheating here a bit for h=-1, v=-1. Can't think of any neat way to
    ## get the actual `at' values of the panel (Can pass it in though)

    if (h<0)
    {
        scale <- current.viewport()$yscale
        at <- pretty(scale)
        at <- at[at>scale[1] & at < scale[2]]
        for(i in seq(along=at))
            grid.lines(y=rep(at[i],2), default.units="native",
                       gp = gpar(col = col.line, lty = lty, lwd = lwd))
    }
    if (v<0)
    {
        scale <- current.viewport()$xscale
        at <- lpretty(scale)
        at <- at[at>scale[1] & at < scale[2]]
        for(i in seq(along=at))
            grid.lines(x=rep(at[i],2), default.units="native",
                       gp = gpar(col = col.line, lty = lty, lwd = lwd))
    }
}





panel.lmline <-
    function(x, y, ...)
{
    x <- as.numeric(x)
    y <- as.numeric(y)
    if (length(x)>0) panel.abline(lm(y ~ x), ...) 
}


prepanel.lmline <-
    function(x, y, ...)
{
    x <- as.numeric(x)
    y <- as.numeric(y)

    if (length(x)>0) {
        coeff <- coef(lm(y~x))
        tem <- coeff[1] + coeff[2] * range(x)
        list(xlim=range(x), ylim=range(y,tem), 
             dx=diff(range(x)), dy=diff(tem))         
    }
    else list(xlim=c(NA,NA), ylim=c(NA,NA), dx=NA, dy=NA)
}










panel.loess <-
    function(x, y, span = 2/3, degree = 1,
             family = c("symmetric", "gaussian"),
             evaluation = 50,
             lwd = add.line$lwd, lty = add.line$lty,
             col,
             col.line = add.line$col,
             ...)
{
    x <- as.numeric(x)
    y <- as.numeric(y)

    if (length(x)>0) {

        if (!missing(col)) {
            if (missing(col.line)) col.line <- col
        }

        add.line <- trellis.par.get("add.line")
        
        smooth <- modreg::loess.smooth(x, y, span = span, family = family,
                                       degree = degree, evaluation = evaluation)
        grid.lines(x=smooth$x, y=smooth$y, default.units = "native",
                   gp = gpar(col = col.line, lty = lty, lwd = lwd))
    }
}


prepanel.loess <-
    function(x, y, span = 2/3, degree = 1,
             family = c("symmetric", "gaussian"),
             evaluation = 50,
             lwd = add.line$lwd, lty = add.line$lty,
             col = add.line$col, ...)
{
    x <- as.numeric(x)
    y <- as.numeric(y)

    if (length(x)>0) {
        add.line <- trellis.par.get("add.line")
        
        smooth <- modreg::loess.smooth(x, y, span = span, family = family,
                                       degree = degree, evaluation = evaluation)
        list(xlim = range(x,smooth$x),
             ylim = range(y,smooth$y),
             dx = diff(smooth$x),
             dy = diff(smooth$y))
    }
    else list(xlim=c(NA,NA), ylim=c(NA,NA), dx=NA, dy=NA)
}



# panel.smooth <-
#     function(x, y, span = 2/3, degree = 1, zero.line = FALSE,
#              family = c("symmetric", "gaussian"),
#              evaluation = 50,
#              lwd = add.line$lwd, lty = add.line$lty,
#              col = add.line$col, ...)
# {
#     if (zero.line) abline(h=0, ...)
#     panel.loess(x, y, span = span, family = family,
#                 degree = degree, evaluation = evaluation, ...)
#     panel.xyplot(x, ,y, ...)
# }
## base R function exists




panel.superpose <-
    function(x, y = NULL, subscripts, groups,
             panel.groups = "panel.xyplot",
             col,
             col.line = superpose.line$col,
             col.symbol = superpose.symbol$col,
             pch = superpose.symbol$pch,
             cex = superpose.symbol$cex, 
             lty = superpose.line$lty,
             lwd = superpose.line$lwd,
             ...)
{
    x <- as.numeric(x)
    if (!is.null(y)) y <- as.numeric(y)

    if (length(x)>0) {

        if (!missing(col)) {
            if (missing(col.line)) col.line <- col
            if (missing(col.symbol)) col.symbol <- col
        }

        superpose.symbol <- trellis.par.get("superpose.symbol")
        superpose.line <- trellis.par.get("superpose.line")

        vals <-
            if (is.factor(groups)) levels(groups)
            else sort(unique(groups))
        nvals <- length(vals)
        col.line <- rep(col.line, length=nvals)
        col.symbol <- rep(col.symbol, length=nvals)
        pch <- rep(pch, length=nvals)
        lty <- rep(lty, length=nvals)
        lwd <- rep(lwd, length=nvals)
        cex <- rep(cex, length=nvals)

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

        for (i in seq(along=vals)) {

            id <- (groups[subscripts] == vals[i])
            if (any(id)) {
                args <- list(x=x[id],
                             groups = groups,
                             subscripts = subscripts[id],
                             pch = pch[i], cex = cex[i],
                             col.line = col.line[i],
                             col.symbol = col.symbol[i],
                             lty = lty[i],
                             lwd = lwd[i], ...)
                if (!is.null(y)) args$y=y[id]

                do.call("panel.groups", args)
            }
        }
    }
}












panel.superpose.2 <- 
    function (x, y, subscripts, groups, col, col.line = superpose.line$col,
              col.symbol = superpose.symbol$col, pch = superpose.symbol$pch,
              cex = superpose.symbol$cex, lty = superpose.line$lty,
              lwd = superpose.line$lwd, type="p", ...)
{
    
    ##   `panel.superpose.2' :  This is a version of the 'panel.superpose'
    ##   Trellis panel function that allows the plot `type' to change between
    ##   superimposed (overlayed) data sets.  See the `panel.xyplot' function
    ##   for details on the `type' option which is usually a single character,
    ##   but here is a character vector with each element specifying the
    ##   plot style of each subsequently-overlayed plot.
    ##                        ---  Neil Klepeis, 26-Dec-2001
    
    x <- as.numeric(x)
    y <- as.numeric(y)

    if (length(x) > 0) {
        if (!missing(col)) {
            if (missing(col.line))
                col.line <- col
            if (missing(col.symbol))
                col.symbol <- col
        }
        superpose.symbol <- trellis.par.get("superpose.symbol")
        superpose.line <- trellis.par.get("superpose.line")
        x <- as.numeric(x)
        y <- as.numeric(y)
        vals <-
            if (is.factor(groups)) levels(groups)
            else sort(unique(groups))
        nvals <- length(vals)
        col.line <- rep(col.line, length = nvals)
        col.symbol <- rep(col.symbol, length = nvals)
        pch <- rep(pch, length = nvals)
        lty <- rep(lty, length = nvals)
        lwd <- rep(lwd, length = nvals)
        cex <- rep(cex, length = nvals)
        type <- rep(type, length = nvals)      # new line here
        for (i in seq(along = vals)) {
            id <- (groups[subscripts] == vals[i])
            if (any(id))
                panel.xyplot(x = x[id], y = y[id], pch = pch[i],
                  cex = cex[i], col.line = col.line[i], col.symbol = col.symbol[i],
                  lty = lty[i], lwd = lwd[i], type=type[i], ...)
        }
    }
}







panel.linejoin <-
    function(x, y, fun = mean,
             horizontal = TRUE,
             lwd = reference.line$lwd,
             lty = reference.line$lty,
             col,
             col.line = reference.line$col,
             ...)
{
    x <- as.numeric(x)
    y <- as.numeric(y)

    reference.line = trellis.par.get("reference.line")
    if (!missing(col)) {
        if (missing(col.line)) col.line <- col
    }
    if (horizontal) {
        vals <- unique(sort(y))
        yy <- seq(along = vals)
        xx <- numeric(length(yy))
        for (i in yy)
            xx[i] <- fun(x[y == vals[i]])
        llines(xx, vals[yy], col = col.line, lty = lty, lwd = lwd, ...)
    }
    else {
        vals <- unique(sort(x))
        xx <- seq(along = vals)
        yy <- numeric(length(xx))
        for (i in xx)
            yy[i] <- fun(y[x == vals[i]])
        llines(vals[xx], yy, col = col.line, lty = lty, lwd = lwd, ...)
     }
}



panel.mathdensity <-
    function(dmath = dnorm,
             args = list(mean = 0, sd = 1),
             n = 50,
             col,
             col.line = reference.line$col,
             lwd = reference.line$lwd,
             lty = reference.line$lty,
             ...)
{
    reference.line <- trellis.par.get("reference.line")
    if (!missing(col)) {
        if (missing(col.line)) col.line <- col
    }
    x <- do.breaks(endpoints = current.viewport()$xscale,
                   nint = n)
    y <- do.call("dmath", c(list(x = x),args))
    llines(x = x, y = y, col = col.line, lwd = lwd, lty = lty, ...)
}




### Copyright 2001  Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA



prepanel.default.parallel <-
    function(x, y, type, ...)
{
    list(xlim = c(0,1),
         ylim = c(0,1),
         dx = 1,
         dy = 1)
}



panel.parallel <- function(z, subscripts,
                           col=superpose.line$col,
                           lwd=superpose.line$lwd,
                           lty=superpose.line$lty, ...)
{

    superpose.line <- trellis.par.get("superpose.line")
    reference.line <- trellis.par.get("reference.line")

    n.r <- ncol(z)
    n.c <- length(subscripts)
    col <- rep(col, length=n.c)
    lty <- rep(lty, length=n.c)
    lwd <- rep(lwd, length=n.c)

    llim <- numeric(n.r)
    ulim <- numeric(n.r)
    dif <- numeric(n.r)
    if (n.r > 0)
        for(i in 1:n.r) {
            grid.lines(x = c(0,1), y = c(i,i),
                       default.units = "native",
                       gp = gpar(col = reference.line$col,
                       lwd = reference.line$lwd,
                       lty = reference.line$lty))
            llim[i] <- range(as.numeric(z[,i]))[1]
            ulim[i] <- range(as.numeric(z[,i]))[2]
            dif[i] <- ulim[i] - llim[i]
        }
   

    for (i in seq(along=subscripts))
    {
        x <- (as.numeric(z[subscripts[i],,])-llim)/dif
        grid.lines(x = x,
                   y=1:n.r, 
                   gp = gpar(col=col[i], lty=lty[i], lwd=lwd[i]),
                   default.units="native")
    }
    
}






parallel <-
    function(formula,
             data = parent.frame(),
             aspect = "fill",
             between = list(x = 0.5, y = 0.5),
             layout = NULL,
             panel = "panel.parallel",
             prepanel = NULL,
             scales = list(),
             strip = TRUE,
             groups = NULL,
             xlab = NULL,
             xlim,
             ylab = NULL,
             ylim,
             varnames,
             ...,
             subscripts = !is.null(groups),
             subset = TRUE)
{

    ## dots <- eval(substitute(list(...)), data, parent.frame())
    dots <- list(...)

    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)

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

    ## Step 1: Evaluate x, y, etc. and do some preprocessing
    
    form <- latticeParseFormula(formula, data)
    cond <- form$condition
    number.of.cond <- length(cond)
    x <- as.data.frame(form$right)
    if (number.of.cond == 0) {
        strip <- FALSE
        cond <- list(as.factor(rep(1, nrow(x))))
        layout <- c(1,1,1)
        number.of.cond <- 1
    }
    if (!missing(varnames)) colnames(x) <-
        eval(substitute(varnames), data, parent.frame())

    groups <- eval(substitute(groups), data, parent.frame())
    subset <- eval(substitute(subset), data, parent.frame())
    if ("subscripts" %in% names(formals(eval(panel)))) subscripts <- TRUE
    subscr <- seq(along=x[,1])
    x <- x[subset,, drop = TRUE]
    subscr <- subscr[subset, drop = TRUE]
    
    ##if(!(is.numeric(x) && is.numeric(y)))
    ##    warning("Both x and y should be numeric")    WHAT ?


    ## create a skeleton trellis object with the
    ## less complicated components:

    foo <- do.call("trellis.skeleton",
                   c(list(aspect = aspect,
                          between = between,
                          strip = strip,
                          panel = panel,
                          xlab = xlab,
                          ylab = ylab), dots))

    dots <- foo$dots # arguments not processed by trellis.skeleton
    foo <- foo$foo
    foo$call <- match.call()
    foo$fontsize.normal <- 10
    foo$fontsize.small <- 8

    ## This is for cases like xlab/ylab = list(cex=2)
    if (is.list(foo$xlab) && !is.characterOrExpression(foo$xlab$label))
        foo$xlab$label <- "Parallel Coordinate Plot"
    if (is.list(foo$ylab) && !is.characterOrExpression(foo$ylab$label))
        foo$ylab <- NULL

    ## Step 2: Compute scales.common (leaving out limits for now)

    ## overriding at and labels, maybe not necessary
    
    ## scales <- eval(substitute(scales), data, parent.frame())
    if (is.character(scales)) scales <- list(relation = scales)
    if (is.null(scales$alternating)) {
        if (is.null(scales$y)) scales$y <- list(alternating = FALSE)
        else if (is.null(scales$y$alternating)) scales$y$alternating <- FALSE
        ## bug if y="free" but who cares
    }
    foo <- c(foo, 
             do.call("construct.scales", scales))
    foo$x.scales$at <- c(0,1)
    foo$x.scales$labels <- c("Min","Max")
    foo$y.scales$at <- 1:ncol(x)
    foo$y.scales$labels <- colnames(x)
    

    ## Step 3: Decide if limits were specified in call:

    if (missing(xlim)) xlim <- extend.limits(c(0,1))
    if (missing(ylim)) ylim <- extend.limits(c(1,ncol(x)), prop = 0.03) 
    have.xlim <- TRUE
    if (!is.null(foo$x.scales$limit)) {
        have.xlim <- TRUE
        xlim <- foo$x.scales$limit
    }
    have.ylim <- TRUE
    if (!is.null(foo$y.scales$limit)) {
        have.ylim <- TRUE
        ylim <- foo$y.scales$limit
    }
    
    ## Step 4: Decide if log scales are being used:

    have.xlog <- !is.logical(foo$x.scales$log) || foo$x.scales$log
    have.ylog <- !is.logical(foo$y.scales$log) || foo$y.scales$log
    if (have.xlog) {
        xlog <- foo$x.scales$log
        xbase <-
            if (is.logical(xlog)) 10
            else if (is.numeric(xlog)) xlog
            else if (xlog == "e") exp(1)

        x <- log(x, xbase)
        foo$x.scales$log <- FALSE
        ## This is because No further changes will be
        ## necessary while printing since x-axes are not
        ## marked (many x axes)
    }
    if (have.ylog) {
        warning("cannot have log y-scale")
        foo$y.scales$log <- FALSE
    }
    
    ## Step 5: Process cond

    cond <- lapply(cond, as.factorOrShingle, subset, drop = TRUE)
    cond.max.level <- unlist(lapply(cond, nlevels))


    id.na <- FALSE
    for (j in 1:ncol(x))
        id.na <- id.na | is.na(x[,j])
    for (var in cond)
        id.na <- id.na | is.na(var)
    if (!any(!id.na)) stop("nothing to draw")
    ## Nothing simpler ?

    foo$condlevels <- lapply(cond, levels)

    ## Step 6: Evaluate layout, panel.args.common and panel.args


    foo$panel.args.common <-
        c(list(z = x, groups = groups), dots)

    layout <- compute.layout(layout, cond.max.level, skip = foo$skip)
    plots.per.page <- max(layout[1] * layout[2], layout[2])
    number.of.pages <- layout[3]
    foo$skip <- rep(foo$skip, length = plots.per.page)
    foo$layout <- layout
    nplots <- plots.per.page * number.of.pages

    foo$panel.args <- as.list(1:nplots)
    cond.current.level <- rep(1,number.of.cond)
    panel.number <- 1 # this is a counter for panel number
    for (page.number in 1:number.of.pages)
        if (!any(cond.max.level-cond.current.level<0))
            for (plot in 1:plots.per.page) {

                if (foo$skip[plot]) foo$panel.args[[panel.number]] <- FALSE
                else if(!any(cond.max.level-cond.current.level<0)) {

                    id <- !id.na
                    for(i in 1:number.of.cond)
                    {
                        var <- cond[[i]]
                        id <- id &
                        if (is.shingle(var))
                            ((var >=
                              levels(var)[[cond.current.level[i]]][1])
                             & (var <=
                                levels(var)[[cond.current.level[i]]][2]))
                        else (as.numeric(var) == cond.current.level[i])
                    }

                    foo$panel.args[[panel.number]] <-
                        list(subscripts = subscr[id])

                    cond.current.level <-
                        cupdate(cond.current.level,
                                cond.max.level)
                }

                panel.number <- panel.number + 1
            }

    foo <- c(foo,
             limits.and.aspect(prepanel.default.parallel,
                               prepanel = prepanel, 
                               have.xlim = have.xlim, xlim = xlim, 
                               have.ylim = have.ylim, ylim = ylim, 
                               x.relation = foo$x.scales$relation,
                               y.relation = foo$y.scales$relation,
                               panel.args.common = foo$panel.args.common,
                               panel.args = foo$panel.args,
                               aspect = aspect,
                               nplots = nplots,
                               x.axs = foo$x.scales$axs,
                               y.axs = foo$y.scales$axs))

    class(foo) <- "trellis"
    foo
}















### Copyright 2001  Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA



## not quite what it should be
plot.shingle <-
    function(x, col = bar.fill$col, aspect = "fill", ...)
{

    bar.fill <- trellis.par.get("bar.fill")
    foo <- list(call = match.call(),
                aspect.fill = aspect == "fill",
                aspect.ratio = if (is.numeric(aspect)) aspect else 1,
                as.table = FALSE,
                condlevels = "1",
                key = NULL,
                layout=c(1,1,1),
                page = NULL,
                panel = function(x, col) {
                    ## x is the list of intervals
                    num.l.y <- length(x)
                    if (num.l.y>0)
                        for(i in 1:num.l.y)
                            grid.rect(x = x[[i]] %*% c(.5,.5),
                                      y = i,
                                      width = diff(x[[i]]),
                                      height = .5,
                                      default.units = "native",
                                      gp = gpar(fill=col)) 
                },
                panel.args = list(list()),
                panel.args.common = list(x=levels(x), col = col),
                par.strip.text = trellis.par.get("add.text"),
                skip = FALSE,
                strip = FALSE,
                main = NULL,
                sub = NULL,
                xlab = list(label = "Range", col = "black", cex = 1, font =1),
                ylab = list(label = "Panel", col = "black", cex = 1, font =1),
                x.scales = 1,
                y.scales = 1,
                x.between = 0,
                y.between = 0,
                x.alternating = 1,
                y.alternating = 1,
                fontsize.normal = 10,
                fontsize.small = 8)
    
    num.l.y <- nlevels(x)
    foo$x.limits <- extend.limits(range(x, levels(x)))
    foo$y.limits <- extend.limits(c(1,num.l.y),
                                  length = .5+num.l.y)


    foo$x.scales <- list(relation = "same",
                         draw = TRUE,
                         alternating = 1,
                         at = FALSE,
                         labels = FALSE,
                         tck = c(1, 1),
                         font = 1,
                         col = FALSE,
                         log = FALSE,
                         cex = c(1, 1),
                         rot = c(FALSE, FALSE),
                         tick.number = 5)
    
    foo$y.scales <- list(relation = "same",
                         draw = TRUE,
                         alternating = 1,
                         at = 1:num.l.y,
                         labels = FALSE,
                         tck = c(1, 1),
                         font = 1,
                         col = FALSE,
                         log = FALSE,
                         cex = c(1, 1),
                         rot = c(FALSE, FALSE),
                         tick.number = num.l.y)
    
    class(foo) <- "trellis"
    foo
    
}






### Copyright 2001  Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA






## the pos'th entry in the unit vector x is replaced by the unit u.
## Essentially does what x[pos] <- u should have done, only u can only
## be a unit of length 1

rearrangeUnit <- function(x, pos, u)
{
    if (unit.length(x) == 1)
        u
    else if (pos == 1)
        unit.c(u, x[(pos+1):unit.length(x)])
    else if (pos == unit.length(x))
        unit.c(x[1:(pos-1)], u)
    else
        unit.c(x[1:(pos-1)], u, x[(pos+1):unit.length(x)])
}





# convenience function for the most common type of key

simpleKey <- function(text, points = TRUE,
                      rectangles = FALSE,
                      lines = FALSE, ...)
{
    foo <- seq(along = text)
    ans <- list(text = list(lab = text), ...)

    if (points) ans$points <-
        Rows(trellis.par.get("superpose.symbol"), foo)

    if (rectangles) {
        col.regions <- trellis.par.get("regions")$col
        numcol.r <- length(col.regions)
        numcol <- length(foo)
        ans$rectangles <-
            list(col = 
                 if (numcol.r <= numcol) rep(col.regions, length = numcol)
                 else col.regions[floor(1+(foo-1)*(numcol.r-1)/(numcol-1))])
    }
    if (lines) ans$lines <-
        Rows(trellis.par.get("superpose.line"), foo)
    ans
}
             





draw.key <- function(key, draw = FALSE, vp = NULL)
{
    if (!is.list(key)) stop("key must be a list")
    
    max.length <- 0
    ## maximum of the `row-lengths' of the above
    ## components. There is some scope for confusion
    ## here, e.g., if col is specified in key as a
    ## length 6 vector, and then lines=list(lty=1:3),
    ## what should be the length of that lines column ?
    ## If 3, what happens if lines=list() ?
    ## (Strangely enough, S+ accepts lines=list()
    ## if col (etc) is NOT specified outside, but not
    ## if it is)
    
    process.key <-
        function(between = 2,
                 align = TRUE,
                 title = NULL,
                 rep = TRUE,
                 background = trellis.par.get("background")$col,
                 border = FALSE,
                 transparent = FALSE, 
                 columns = 1,
                 divide = 3,
                 between.columns = 3,
                 cex = 1,
                 cex.title = 1.5 * max(cex),
                 col = "black", 
                 lty = 1,
                 lwd = 1,
                 font = 1, 
                 pch = 8,
                 adj = 0,
                 type = "l", 
                 size = 5, 
                 angle = 0, 
                 density = -1,
                 ...)
        {
            list(between = between,
                 align = align,
                 title = title,
                 rep = rep,
                 background = background,
                 border = border,
                 transparent = transparent, 
                 columns = columns,
                 divide = divide,
                 between.columns = between.columns,
                 cex = cex,
                 cex.title = cex.title,
                 col = col,
                 lty = lty,
                 lwd = lwd,
                 font = font, 
                 pch = pch,
                 adj = adj,
                 type = type, 
                 size = size, 
                 angle = angle, 
                 density = density,
                 ...)
        }

    default.fontsize <- trellis.par.get("fontsize")$default

    key <- do.call("process.key", key)

    key.length <- length(key)
    key.names <- names(key)    # Need to update
    if (is.logical(key$border)) 
        key$border <-
            if (key$border) "black"
            else "transparent"

    components <- list()

    for(i in 1:key.length) {

        curname <- pmatch(key.names[i], c("text", "rectangles", "lines", "points"))

        if (is.na(curname)) {
            ;## do nothing
        }
        else if (curname == 1) { # "text"
            if (!(is.characterOrExpression(key[[i]][[1]])))
                stop("first component of text has to be vector of labels")
            pars <- list(labels = key[[i]][[1]],
                         col = key$col,
                         adj = key$adj,
                         cex = key$cex,
                         font = key$font)
            key[[i]][[1]] <- NULL
            pars[names(key[[i]])] <- key[[i]]

            tmplen <- length(pars$labels)
            for (j in 1:length(pars))
                if (is.character(pars))
                    pars[[j]] <- rep(pars[[j]], length = tmplen)

            max.length <- max(max.length, tmplen)
            components[[length(components)+1]] <-
                list(type = "text", pars = pars, length = tmplen)

        }
        else if (curname == 2) { # "rectangles"

            pars <- list(col = key$col,
                         size = key$size,
                         angle = key$angle,
                         density = key$density)
            
            pars[names(key[[i]])] <- key[[i]]

            tmplen <- max(unlist(lapply(pars,length)))
            max.length <- max(max.length, tmplen)
            components[[length(components)+1]] <-
                list(type = "rectangles", pars = pars, length = tmplen)
            
        }
        else if (curname == 3) { # "lines"

            pars <- list(col = key$col,
                         size = key$size,
                         lty = key$lty,
                         cex = key$cex,
                         lwd = key$lwd,
                         type = key$type)

            pars[names(key[[i]])] <- key[[i]]

            tmplen <- max(unlist(lapply(pars,length)))
            max.length <- max(max.length, tmplen)
            components[[length(components)+1]] <-
                list(type = "lines", pars = pars, length = tmplen)
            
        }
        else if (curname == 4) { # "points"

            pars <- list(col = key$col,
                         cex = key$cex,
                         pch = key$pch)
                         
            pars[names(key[[i]])] <- key[[i]]

            tmplen <- max(unlist(lapply(pars,length)))
            max.length <- max(max.length, tmplen)
            components[[length(components)+1]] <-
                list(type = "points", pars = pars, length = tmplen)

        }
    }


    
    number.of.components <- length(components)
    ## number of components named one of "text",
    ## "lines", "rectangles" or "points"
    if (number.of.components == 0)
        stop("Invalid key, need at least one component named lines, text, rect or points")

    ## The next part makes sure all components have same length,
    ## except text, which should be as long as the number of labels

    ## Update (9/11/2003): but that doesn't always make sense --- Re:
    ## r-help message from Alexander.Herr@csiro.au (though it seems
    ## that's S+ behaviour on Linux at least). Each component should
    ## be allowed to have its own length (that's what the lattice docs
    ## suggest too, don't know why). Anyway, I'm adding a rep = TRUE
    ## argument to the key list, which controls whether each column
    ## will be repeated as necessary to have the same length.

    
    for (i in 1:number.of.components)
        if (components[[i]]$type != "text") {
            components[[i]]$pars <-
                lapply(components[[i]]$pars, rep,
                       length = if (key$rep) max.length
                       else components[[i]]$length)
            if (key$rep) components[[i]]$length <- max.length
        }
        else{
            ## NB: rep doesn't work with expressions of length > 1
            components[[i]]$pars <-
                c(components[[i]]$pars[1],
                  lapply(components[[i]]$pars[-1], rep,
                         length = components[[i]]$length))
        }

    column.blocks <- key$columns
    rows.per.block <- ceiling(max.length/column.blocks)

    if (column.blocks > max.length) warning("not enough rows for columns")
    
    key$between <- rep(key$between, length = number.of.components)

    
    if (key$align) {

        ## Setting up the layout


	## The problem of allocating space for text (character strings
	## or expressions) is dealt with as follows: 

	## Each row and column will take exactly as much space as
	## necessary. As steps in the construction, a matrix
	## textMatrix (of same dimensions as the layout) will contain
	## either 0, meaning that entry is not text, or n > 0, meaning
	## that entry has the text given by textList[[n]], where
	## textList is a list consisting of character strings or
	## expressions.



        n.row <- rows.per.block + 1
        n.col <- column.blocks * (1 + 3 * number.of.components) - 1

	textMatrix <- matrix(0, n.row, n.col)
	textList <- list()
	textCex <- numeric(0)

        heights.x <- rep(1, n.row)
        heights.units <- rep("lines", n.row)
        heights.data <- as.list(1:n.row)

        if (key$title != "" && is.characterOrExpression(key$title)) {
            heights.x[1] <- 1.2 * key$cex.title
            heights.units[1] <- "strheight"
            heights.data[[1]] <- key$title
        }
        else heights.x[1] <- 0


        widths.x <- rep(key$between.column, n.col)
        widths.units <- rep("strwidth", n.col)
        widths.data <- as.list(rep("o", n.col))



        for (i in 1:column.blocks) {
            widths.x[(1:number.of.components-1)*3+1 +
                     (i-1)*3*number.of.components + i-1] <-
                         key$between/2
            
            widths.x[(1:number.of.components-1)*3+1 +
                     (i-1)*3*number.of.components + i+1] <-
                         key$between/2
        }
    
        
	index <- 1

        for (i in 1:number.of.components) {

            cur <- components[[i]]

            id <- (1:column.blocks - 1) *
                (number.of.components * 3 + 1) + i * 3 - 1

            if (cur$type == "text") {

                for (j in 1:cur$length) {

                    colblck <- ceiling(j / rows.per.block)

                    xx <- (colblck - 1) *
                        (number.of.components * 3 + 1) + i * 3 - 1

                    yy <- j %% rows.per.block + 1
                    if (yy == 1) yy <- rows.per.block + 1

		    textMatrix[yy, xx] <- index
		    textList <- c(textList, list(cur$pars$labels[j]) )
		    textCex <- c(textCex, cur$pars$cex[j])
  		    index <- index + 1

		}


            } ## FIXME: do the same as above for those below
            else if (cur$type == "rectangles") {
                widths.x[id] <- max(cur$pars$size)
            }
            else if (cur$type == "lines") {
                widths.x[id] <- max(cur$pars$size)
            }
            else if (cur$type == "points") {
                widths.x[id] <- max(cur$pars$cex)
            }
        }


        ## Need to adjust the heights and widths 
        
        ## adjusting heights
        heights.insertlist.position <- 0
        heights.insertlist.unit <- unit(1, "null")

        for (i in 1:n.row) {
            textLocations <- textMatrix[i,]
            textLocations <- textLocations[textLocations>0]
            if (any(textLocations)) {

                strbar <- textList[textLocations]
                heights.insertlist.position <- c(heights.insertlist.position, i)
                heights.insertlist.unit <-
                    unit.c(heights.insertlist.unit,
                           unit(.2, "lines") + max(unit(textCex[textLocations], "strheight", strbar)))
            }
        }


        layout.heights <- unit(heights.x, heights.units, data=heights.data)
        if (length(heights.insertlist.position)>1)
            for (indx in 2:length(heights.insertlist.position))
                layout.heights <-
                    rearrangeUnit(layout.heights, heights.insertlist.position[indx],
                                  heights.insertlist.unit[indx])





        ## adjusting widths
        widths.insertlist.position <- 0
        widths.insertlist.unit <- unit(1, "null")




        for (i in 1:n.col) {
            textLocations <- textMatrix[,i]
            textLocations <- textLocations[textLocations>0]
            if (any(textLocations)) {

                strbar <- textList[textLocations]
                widths.insertlist.position <- c(widths.insertlist.position, i)
                widths.insertlist.unit <-
                    unit.c(widths.insertlist.unit,
                           max(unit(textCex[textLocations], "strwidth", strbar)))
            }
        }


        layout.widths <- unit(widths.x, widths.units, data=widths.data)
        if (length(widths.insertlist.position)>1)
            for (indx in 2:length(widths.insertlist.position))
                layout.widths <-
                    rearrangeUnit(layout.widths, widths.insertlist.position[indx],
                                  widths.insertlist.unit[indx])


        key.layout <- grid.layout(nrow = n.row, ncol = n.col,
                                  widths = layout.widths,
                                  heights = layout.heights,
                                  respect = FALSE)

        ## OK, layout set up, now to draw the key - no

        
        key.gf <- grid.frame(layout = key.layout, vp = vp,
                             gp = gpar(fontsize = default.fontsize),
                             draw = FALSE)

        if (!key$transparent) {
            grid.place(key.gf,
                       grid.rect(gp=gpar(fill = key$background, col = key$border),
                                 draw = FALSE),
                       draw = FALSE, row = NULL, col = NULL)
        }
        else
            grid.place(key.gf,
                       grid.rect(gp=gpar(col=key$border), draw = FALSE),
                       draw = FALSE, row = NULL, col = NULL)

        ## Title
        if (!is.null(key$title))
            grid.place(key.gf, 
                       grid.text(label = key$title, draw = FALSE,
                                 gp = gpar(fontsize = default.fontsize * key$cex.title)),
                       row=1, col = NULL, draw = FALSE)
        

        
        for (i in 1:number.of.components) {

            cur <- components[[i]]

            for (j in 1:cur$length) {

                colblck <- ceiling(j / rows.per.block)

                xx <- (colblck - 1) *
                    (number.of.components*3 + 1) + i*3 - 1

                yy <- j %% rows.per.block + 1
                if (yy == 1) yy <- rows.per.block + 1

                if (cur$type == "text") {
                    
                    grid.place(key.gf, 
                               grid.text(x = cur$pars$adj[j],
                                         just = c(
                                         if (cur$pars$adj[j] == 1) "right"
                                         else if (cur$pars$adj[j] == 0) "left"
                                         else "center",
                                         "center"),
                                         label = cur$pars$labels[j],
                                         gp = gpar(col = cur$pars$col[j],
                                         font = cur$pars$font[j],
                                         fontsize = default.fontsize * cur$pars$cex[j]),
                                         draw = FALSE),
                               row = yy, col = xx, draw = FALSE)
                    
                }
                else if (cur$type == "rectangles") {
                    grid.place(key.gf, 
                              grid.rect(width = cur$pars$size[j]/max(cur$pars$size),
                                        ## centred, unlike Trellis, due to aesthetic reasons !
                                        gp = gpar(fill = cur$pars$col[j]), 
                                        draw = FALSE),
                              row = yy, col = xx, draw = FALSE)
                    
                    ## Need to make changes to support angle/density
                }
                else if (cur$type == "lines") {
                    if (cur$pars$type[j] == "l") {
                        grid.place(key.gf,
                                  grid.lines(x = c(0,1) * cur$pars$size[j]/max(cur$pars$size),
                                             ## ^^ this should be centered as well, but since the
                                             ## chances that someone would actually use this feature
                                             ## are astronomical, I'm leaving that for later.
                                             y = c(.5, .5),
                                             gp = gpar(col = cur$pars$col[j],
                                             lty = cur$pars$lty[j],
                                             lwd = cur$pars$lwd[j]),
                                             draw = FALSE),
                                  row = yy, col = xx, draw = FALSE)
                    }
                    else if (cur$pars$type[j] == "p") {
                        grid.place(key.gf,
                                   grid.points(x=.5, y=.5, 
                                               gp = gpar(col = cur$pars$col[j]),
                                               size = unit(cur$pars$cex[j] * 2.5, "mm"),
                                               pch = cur$pars$pch[j],
                                               draw = FALSE),
                                   row = yy, col = xx, draw = FALSE)
                    }
                    else { # if (cur$pars$type[j] == "b" or "o") -- not differentiating
                        grid.place(key.gf, 
                                  grid.lines(x = c(0,1) * cur$pars$size[j]/max(cur$pars$size),
                                             ## ^^ this should be centered as well, but since the
                                             ## chances that someone would actually use this feature
                                             ## are astronomical, I'm leaving that for later.
                                             y = c(.5, .5),
                                             gp = gpar(col = cur$pars$col[j],
                                             lty = cur$pars$lty[j],
                                             lwd = cur$pars$lwd[j]),
                                             draw = FALSE),
                                  row = yy, col = xx, draw = FALSE)

                        grid.place(key.gf, 
                                   grid.points(x = (1:key$divide-1)/(key$divide-1),
                                               y = rep(.5, key$divide),
                                               gp = gpar(col = cur$pars$col[j]),
                                               size = unit(cur$pars$cex[j] * 2.5, "mm"),
                                               pch = cur$pars$pch[j],
                                               draw = FALSE),
                                   row = yy, col = xx, draw = FALSE)
                    }
                }
                else if (cur$type == "points") {
                    if (is.character(cur$pars$pch[j]))
                        grid.place(key.gf, 
                                  grid.text(lab = cur$pars$pch[j], x=.5, y=.5, 
                                            gp = gpar(col = cur$pars$col[j],
                                            fontsize = cur$pars$cex[j] * 10),
                                            draw = FALSE),
                                  row = yy, col = xx, draw = FALSE)
                    else {
                        grid.place(key.gf,
                                  grid.points(x=.5, y=.5, 
                                              gp = gpar(col = cur$pars$col[j]),
                                              size = unit(cur$pars$cex[j] * 2.5, "mm"),
                                              pch = cur$pars$pch[j],
                                              draw = FALSE),
                                  row = yy, col = xx, draw = FALSE)
                    }
                }

            }

        }

    }
    else stop("sorry, align=F not supported (yet ?)")


    if (draw)
        grid.draw(key.gf)

    key.gf
}


























draw.colorkey <- function(key, draw = FALSE, vp = NULL)
{
    if (!is.list(key)) stop("key must be a list")
    
    process.key <-
        function(col,
                 at,
                 tick.number = 7,
                 width = 2,
                 height = 1,
                 space = "right",
                 ...)
        {
            list(col = col,
                 at = at,
                 tick.number = tick.number,
                 width = width,
                 height = height,
                 space = space,
                 ...)
        }

    default.fontsize <- trellis.par.get("fontsize")$default
    key <- do.call("process.key", key)
    
    ## Getting the locations/dimensions/centers of the rectangles
    key$at <- sort(key$at) ## should check if ordered
    if (length(key$at)!=length(key$col)+1) stop("length(col) must be length(at)-1")
    atrange <- range(key$at)
    scat <- .5 - key$height/2 + key$height *
        (key$at - atrange[1]) / diff(atrange)
    recnum <- length(scat)-1
    reccentre <- (scat[-1] + scat[-length(scat)]) / 2
    recdim <- diff(scat)

    cex <- 0.9
    col <- "black"
    font <- 1
    if (is.null(key$lab)) {
        at <- lpretty(atrange, key$tick.number)
        at <- at[at>=atrange[1] & at<=atrange[2]]
        labels <- as.character(at)
    }
    else if (is.character(key$lab) && length(key$lab)==length(key$at)) {
        at <- key$at
        labels <- as.character(key$lab)
    }
    else if (is.list(key$lab)) {
        if (!is.null(key$lab$at)) at <- key$lab$at
        if (!is.null(key$lab$lab)) labels <- as.character(key$lab$lab)
        if (!is.null(key$lab$cex)) cex <- key$lab$cex
        if (!is.null(key$lab$col)) col <- key$lab$col
        if (!is.null(key$lab$font)) font <- key$lab$font
    }
    else stop("malformed colorkey")
    labscat <- .5 - key$height/2 + key$height *
        (at - atrange[1]) / diff(atrange) # scales tick positions

    which.name <- "W"
    for (ss in labels)
        if (nchar(ss) > nchar(which.name)) which.name <- ss


    ## the tick marks for left and right should be modified


    if (key$space == "right") {

        widths.x <- c(key$width,1)
        widths.units <- rep("strwidth", 2)
        widths.data <- as.list(c("W", paste("--",which.name)))
        
        key.layout <-
            grid.layout(nrow = 1, ncol = 2,
                        widths = unit(widths.x, widths.units, data=widths.data))
        
        key.gf <- grid.frame(layout = key.layout, vp = vp,
                             gp = gpar(fontsize = default.fontsize),
                             draw = FALSE)
        

######

#         for (c in seq(along = key$col))
#             grid.pack(frame = key.gf,
#                       row = 1, col = 1,
#                       grob = grid.rect(y = unit(reccentre[c], "native"),
#                       height = unit(recdim[c], "native"),
#                       gp = gpar(fill = key$col[c], col = NULL), draw = FALSE),
#                       draw = FALSE)

        grid.pack(frame = key.gf, row = 1, col = 1,
                  grob =
                  grid.rect(x = rep(.5, length(reccentre)), 
                            y = reccentre, default.units = "native",
                            height = recdim, 
                            gp=gpar(fill=key$col,  col = NULL), draw = FALSE),
                  draw = FALSE)

        grid.pack(frame = key.gf, col = 1,
                  grob =
                  grid.rect(height = key$height,
                            gp=gpar(col="black"), draw = FALSE),
                  draw = FALSE)
        
        grid.pack(frame = key.gf, col = 1,
                  grob =
                  grid.text(label = paste("-", labels, sep = ""),
                            x = rep(1, length(labscat)),
                            y = labscat,
                            just = c("left","center"),
                            gp=gpar(col = col, fontsize = cex * default.fontsize, font = font),
                            draw = FALSE),
                  draw = FALSE)
    }
    else if (key$space == "left") {

        widths.x <- c(1,key$width)
        widths.units <- rep("strwidth", 2)
        widths.data <- as.list(c(paste("--",which.name), "W"))
        
        key.layout <-
            grid.layout(nrow = 1, ncol = 2,
                        widths = unit(widths.x, widths.units, data=widths.data))
        
        key.gf <- grid.frame(layout = key.layout, vp = vp,
                             gp = gpar(fontsize = default.fontsize), 
                             draw = FALSE)

#        for (c in seq(along = key$col))
#            grid.pack(frame = key.gf,
#                      row = 1, col = 2,
#                      grob = grid.rect(y = unit(reccentre[c], "native"),
#                      height = unit(recdim[c], "native"),
#                      gp = gpar(fill = key$col[c], col = NULL), draw = FALSE),
#                      draw = FALSE)

        grid.pack(frame = key.gf, row = 1, col = 2,
                  grob =
                  grid.rect(x = rep(.5, length(reccentre)),
                            y = unit(reccentre, "native"),
                            height = unit(recdim, "native"),
                            gp=gpar(fill=key$col,  col = NULL), draw = FALSE),
                  draw = FALSE)

        grid.pack(frame = key.gf, col = 2,
                  grob =
                  grid.rect(height = key$height,
                            gp=gpar(col="black"), draw = FALSE),
                  draw = FALSE)

        grid.pack(frame = key.gf, col = 2,
                  grob =
                  grid.text(label = paste(labels, "-", sep = ""),
                            x = rep(0, length(labscat)),
                            y = labscat,
                            just = c("right","center"),
                            gp=gpar(col = col, fontsize = cex * default.fontsize, font = font),
                            draw = FALSE),
                  draw = FALSE)
    }
    else if (key$space == "top") {

        heights.x <- c(1, .2, key$width)
        heights.units <- c("lines", "lines", "strwidth")
        heights.data <- as.list(c("a", "a", "W"))
        
        key.layout <-
            grid.layout(nrow = 3, ncol = 1,
                        heights = unit(heights.x, heights.units, data=heights.data))
        
        key.gf <- grid.frame(layout = key.layout, vp = vp,
                             gp = gpar(fontsize = default.fontsize), 
                             draw = FALSE)

#         for (c in seq(along = key$col))
#             grid.pack(frame = key.gf,
#                       row = 3, col = 1,
#                       grob = grid.rect(x = unit(reccentre[c], "native"),
#                       width = unit(recdim[c], "native"),
#                       gp = gpar(fill = key$col[c], col = NULL), draw = FALSE),
#                       draw = FALSE)

        grid.pack(frame = key.gf, row = 3, col = 1,
                  grob =
                  grid.rect(x = unit(reccentre, "native"),
                            y = rep(.5, length(reccentre)),
                            width = unit(recdim, "native"),
                            gp=gpar(fill=key$col,  col = NULL), draw = FALSE),
                  draw = FALSE)

        grid.pack(frame = key.gf, row = 3,
                  grob =
                  grid.rect(width = key$height,
                            gp=gpar(col="black"), draw = FALSE),
                  draw = FALSE)

        for (c in seq(along = labscat))
            grid.pack(frame = key.gf, row = 2,
                      grob =
                      grid.lines(x = unit(rep(labscat[c], 2), "native"),
                                 gp=gpar(col = col),
                                 draw = FALSE),
                                 draw = FALSE)

        grid.pack(frame = key.gf, row = 1,
                  grob =
                  grid.text(label = labels,
                            x = labscat,
                            just = c("centre","center"),
                            gp=gpar(col = col, fontsize = cex * default.fontsize, font = font),
                            draw = FALSE),
                  draw = FALSE)
    }
    else if (key$space == "bottom") {

        heights.x <- c(key$width, .2, 1)
        heights.units <- c("strwidth", "lines", "lines")
        heights.data <- as.list(c("W", "a", "a"))
        
        key.layout <-
            grid.layout(nrow = 3, ncol = 1,
                        heights = unit(heights.x, heights.units, data=heights.data))
        
        key.gf <- grid.frame(layout = key.layout, vp = vp,
                             gp = gpar(fontsize = default.fontsize),
                             draw = FALSE)
        
#         for (c in seq(along = key$col))
#             grid.pack(frame = key.gf,
#                       row = 1, col = 1,
#                       grob = grid.rect(x = unit(reccentre[c], "native"),
#                       width = unit(recdim[c], "native"),
#                       gp = gpar(fill = key$col[c], col = NULL), draw = FALSE),
#                       draw = FALSE)

        grid.pack(frame = key.gf, row = 1, col = 1,
                  grob =
                  grid.rect(x = unit(reccentre, "native"),
                            y = rep(.5, length(reccentre)),
                            width = unit(recdim, "native"),
                            gp = gpar(fill=key$col, col = NULL), draw = FALSE),
                  draw = FALSE)

        grid.pack(frame = key.gf, row = 1,
                  grob =
                  grid.rect(width = key$height,
                            gp = gpar(col="black"), draw = FALSE),
                  draw = FALSE)

        for (c in seq(along = labscat))
            grid.pack(frame = key.gf, row = 2,
                      grob =
                      grid.lines(x = unit(rep(labscat[c], 2), "native"),
                                 gp=gpar(col = col),
                                 draw = FALSE),
                                 draw = FALSE)

        grid.pack(frame = key.gf, row = 3,
                  grob =
                  grid.text(label = labels,
                            x = labscat,
                            just = c("centre","center"),
                            gp=gpar(col = col, fontsize = cex * default.fontsize, font = font),
                            draw = FALSE),
                  draw = FALSE)
    }
    





    if (draw)
        grid.draw(key.gf)
    
    key.gf
}





















print.trellis <-
    function(x, position, split, more = FALSE,
             newpage = TRUE,
             panel.height = list(1, "null"),
             panel.width = list(1, "null"),
             ...)
{
    if (is.null(dev.list())) trellis.device()
    else if (is.null(trellis.par.get()))
        trellis.device(device = .Device, new = FALSE)
    bg = trellis.par.get("background")$col
    new <- TRUE
    if (get(".lattice.print.more", envir=.LatticeEnv) || !newpage) new <- FALSE
    assign(".lattice.print.more", more, envir=.LatticeEnv)
    usual  <- (missing(position) & missing(split))
    ##if (!new && usual)
    ##    warning("more is relevant only when split/position is specified")

    fontsize.default <- trellis.par.get("fontsize")$default
    
    if (!missing(position)) {
        if (length(position)!=4) stop("Incorrect value of position")
        if (new) {
            grid.newpage()
            grid.rect(gp = gpar(fill = bg, col = "transparent"))
        }
        push.viewport(viewport(x=position[1], y=position[2],
                               width=position[3]-position[1],
                               height=position[4]-position[2],
                               just=c("left","bottom")))
        
        if (!missing(split)) {
            if (length(split)!=4) stop("Incorrect value of split")

            push.viewport(viewport(layout = grid.layout(nrow=split[4],
                                   ncol = split[3])))
            push.viewport(viewport(layout.pos.row = split[2],
                                   layout.pos.col = split[1]))
        }
    }
    
    
    else if (!missing(split)) {
        
        if (length(split)!=4) stop("Incorrect value of split")
        if (new) {
            grid.newpage()
            grid.rect(gp = gpar(fill = bg, col = "transparent"))
        }
        push.viewport(viewport(layout = grid.layout(nrow=split[4],
                               ncol = split[3])))
        push.viewport(viewport(layout.pos.row = split[2],
                               layout.pos.col = split[1]))
    }
    
    panel <- # 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)

    x$strip <- 
        if (is.function(x$strip)) x$strip 
        else if (is.character(x$strip)) get(x$strip)
        else eval(x$strip)

    axis.line <- trellis.par.get("axis.line")
    number.of.cond <- length(x$condlevels)
    
    ##panel.width <- 1
    layout.respect <- !x$aspect.fill
    if (layout.respect) panel.height[[1]] <-
        x$aspect.ratio * panel.width[[1]]

    if (!is.null(x$key)) {
        key.gf <- draw.key(x$key)
        key.space <-
            if ("space" %in% names(x$key)) x$key$space
            else if ("x" %in% names(x$key) ||
                     "corner" %in% names(x$key)) "inside"
            else "top"
    }
    else if (!is.null(x$colorkey)) {
        key.gf <- draw.colorkey(x$colorkey)
        key.space <- 
            if ("space" %in% names(x$colorkey)) x$colorkey$space
            else "right"
    }

    xaxis.col <-
        if (is.logical(x$x.scales$col)) axis.line$col
        else x$x.scales$col
    xaxis.font <-
        if (is.logical(x$x.scales$font)) 1
        else x$x.scales$font
    xaxis.cex <-
        x$x.scales$cex
    xaxis.rot <-
        if (is.logical(x$x.scales$rot)) c(0, 0)
        else x$x.scales$rot
    yaxis.col <-
        if (is.logical(x$y.scales$col)) axis.line$col
        else x$y.scales$col
    yaxis.font <-
        if (is.logical(x$y.scales$font)) 1
        else x$y.scales$font
    yaxis.cex <-
        x$y.scales$cex
    yaxis.rot <-
        if (!is.logical(x$y.scales$rot)) x$y.scales$rot
        else if (x$y.scales$relation != "same" && is.logical(x$y.scales$labels)) c(90, 90)
        else c(0, 0)

    strip.col.default.bg <-
        rep(trellis.par.get("strip.background")$col,length=number.of.cond)
    strip.col.default.fg <-
        rep(trellis.par.get("strip.shingle")$col,length=number.of.cond)


    cond.max.level <- integer(number.of.cond)
    for(i in 1:number.of.cond) {
        cond.max.level[i] <- length(x$condlevels[[i]])
    }

    if(x$layout[1]==0) { # using device dimensions to
        ddim <- par("din") # calculate default layout
        device.aspect <- ddim[2]/ddim[1]
        panel.aspect <- panel.height[[1]]/panel.width[[1]]

        plots.per.page <- x$layout[2]
        m <- max (1, round(sqrt(x$layout[2] * device.aspect/panel.aspect)))
        ## changes made to fix bug (PR#1744)
        n <- ceiling(plots.per.page/m)
        m <- ceiling(plots.per.page/n)
        x$layout[1] <- n
        x$layout[2] <- m

    }
    else plots.per.page <- x$layout[1] * x$layout[2] 



    cols.per.page <- x$layout[1]
    rows.per.page <- x$layout[2]
    number.of.pages <- x$layout[3]
        
    if(cols.per.page>1)
        x.between <- rep(x$x.between, length = cols.per.page-1)
    if(rows.per.page>1) 
        y.between <- rep(x$y.between, length = rows.per.page-1)
    
    x.alternating <- rep(x$x.scales$alternating, length = cols.per.page)
    y.alternating <- rep(x$y.scales$alternating, length = rows.per.page)
    x.relation.same <- x$x.scales$relation == "same"
    y.relation.same <- x$y.scales$relation == "same"

    xlog <- x$x.scales$log
    ylog <- x$y.scales$log
    if (is.logical(xlog) && xlog) xlog <- 10
    if (is.logical(ylog) && ylog) ylog <- 10
    have.xlog <- !is.logical(xlog) || xlog
    have.ylog <- !is.logical(ylog) || ylog
    xlogbase <-
        if (is.numeric(xlog)) xlog
        else exp(1)
    ylogbase <-
        if (is.numeric(ylog)) ylog
        else exp(1)
    xlogpaste <-
        if (have.xlog) paste(as.character(xlog), "^", sep = "")
        else ""
    ylogpaste <-
        if (have.ylog) paste(as.character(ylog), "^", sep = "")
        else ""



    have.main <- !(is.null(x$main$label) || (is.character(x$main$label) && x$main$label==""))
    have.sub <- !(is.null(x$sub$label)   || (is.character(x$sub$label) && x$sub$label==""))
    have.xlab <- !(is.null(x$xlab$label) || (is.character(x$xlab$label) && x$xlab$label==""))
    have.ylab <- !(is.null(x$ylab$label) || (is.character(x$ylab$label) && x$ylab$label==""))

    
    ## Shall calculate the per page layout now:

    ## The idea here is to create a layout with proper widths and
    ## heights (representing the requisite amounts of space required
    ## for different components of the plot -- see descriptions below)
    ## using the various units available in grid.

    ## Most of these components are fairly easy to define, with one
    ## exception -- namely those that involve axis labels. For
    ## instance, one (or more) _columns_ would usually contain the
    ## y-axis tick-labels. The width of this column is determined by
    ## ALL the y-labels; basically, the width of the column would be
    ## the MAXIMUM of the widths of the individual labels.

    ## This is in general not an easy problem, since relative width
    ## depends on the font used (also perhaps the device). Till
    ## lattice version 0.6, this was dealt with naively by treating
    ## the label with highest nchar() to be the widest. Unfortunately,
    ## this was no longer possible with labels that were
    ## expressions. So, after grid.text started supporting expression
    ## markups, the method of determining widths/heights for tick
    ## labels has changed. The new method essentially calculates the
    ## MAXIMUM of several grid UNIT objects (using calls like
    ## max(unit(...))) .

    ## The problem with this is that it is impossible to define the
    ## 'units' argument of those parts of the eventual layout when
    ## it's first being defined (it is not "null", "lines" or anything
    ## like that). So, those parts are calculated as separate units
    ## (via max.unit) and then inserted into the layout later.

    ## All this makes the code a bit difficult to follow. I just hope
    ## this gives some hints to whoever (probably me!) tries to
    ## decipher the following code on some later date.

    
    n.row <- rows.per.page * (number.of.cond + 3) + (rows.per.page-1) + 11
    ##       ^^^^^^^^^^^      ^^^^^^^^^^^^^^^^       ^^^^^^^^^^^^^^^    ^^
    ##          panels         rows per panel           between     see below
    ##               (2 for axes/ticks when relation!=same)

    ## the 11 things are as follows (top to bottom)
    ## 1/2 line space at top
    ## main
    ## key
    ## tick labels
    ## ticks
    ##
    ##   actual panels
    ##
    ## ticks
    ## tick labels
    ## xlab
    ## key
    ## sub
    ## 1/2 line space at bottom

    n.col <- 3 * cols.per.page + (cols.per.page-1) + 9 # similar

    ## the 9 things are as follows (left to right)
    ## 1/2 line space at left
    ## key
    ## ylab
    ## tick labels
    ## ticks
    ##
    ##   actual panels
    ##
    ## ticks
    ## tick labels
    ## key
    ## 1/2 line space at right

    ## The next block applies when aspect is anything other than
    ## "fill", which means that the aspect ratio of panels are
    ## fixed. In grid terms, this means that the 'respect' argument
    ## has to be true for elements of the layout that correspond to
    ## panels.

    ## Earlier code used to set all respect entries to be TRUE in such
    ## cases (no need for matrices then), but that fails with the
    ## complicated layout necessitated by expressions (see above).

    if (layout.respect) {
        layout.respect <- matrix(0, n.row, n.col)

        layout.respect[number.of.cond + 6 + (1:rows.per.page - 1) *
                       (number.of.cond+4), (1:cols.per.page - 1)*4 +
                       8] <- 1

    }

    ## see ?unit before trying to follow this. 

    heights.x <- rep(1, n.row)
    heights.units <- rep("lines", n.row)
    heights.data <- as.list(1:n.row)

    widths.x <- rep(1, n.col)
    widths.units <- rep("lines", n.col)
    widths.data <- as.list(1:n.col) 

    ## fine tuning heights:


    heights.x[number.of.cond + 6 + (1:rows.per.page - 1) * (number.of.cond+4)] <-
        panel.height[[1]] # for the panels
    heights.units[number.of.cond + 6 + (1:rows.per.page - 1) * (number.of.cond+4)] <-
        panel.height[[2]]
    ## was "null" # for the panels

    heights.x[number.of.cond + 7 + (1:rows.per.page - 1) * (number.of.cond+4)] <- 0
    ## This is for the x-axis ticks just below each panel if relation!="same"
    heights.x[number.of.cond + 8 + (1:rows.per.page - 1) * (number.of.cond+4)] <- 0
    ## This is for the x-axis labels just below each panel if relation!="same"

    heights.x[4] <- 0
    heights.x[5] <- 0 # tick axes/labels
    heights.x[n.row-4] <- 0
    heights.x[n.row-5] <- 0



    if (rows.per.page > 1)
        heights.x[number.of.cond + 9 +
                  ((if (x$as.table) 1:(rows.per.page-1)
                  else (rows.per.page-1):1)
                   - 1)*(number.of.cond+4)] <-
                       y.between
    ## y-between


    heights.x[1] <- 0.5
    heights.x[2] <- if (have.main) 2 * x$main$cex else 0
    if (have.main) {
        heights.units[2] <-  "strheight"
        heights.data[[2]] <- x$main$lab
    }



    heights.x[n.row] <- 0.5
    heights.x[n.row-1] <- if (have.sub) 2 * x$sub$cex else 0
    if (have.sub) {
        heights.units[n.row-1] <-  "strheight"
        heights.data[[n.row-1]] <- x$sub$lab
    }

    heights.x[3] <- 0 # for the key
    heights.x[n.row-2] <- 0 # key

    ## next part of the code decides how much space to leave for
    ## x tick-labels. This wasn't that bad earlier, but has become
    ## complicated to support expression-style labels. Not sure if
    ## there's a better way (would definitely need a lot of
    ## redesigning), something to look at later.

    heights.insertlist.position <- 0
    heights.insertlist.unit <- unit(1, "null")

    ## both these dummies, since there is no unit(numeric(0)). These
    ## are necessary for calculating space for axis
    ## labels. Unfortunately this makes the code complicated


    if (x$x.scales$draw) {

        if (x.relation.same) {

            lab <- 
                calculateAxisComponents(x = x$x.limits,
                                        at = x$x.scales$at,
                                        labels = x$x.scales$lab,
                                        have.log = have.xlog,
                                        logbase = xlogbase,
                                        logpaste = xlogpaste,
                                        abbreviate = x$x.scales$abbr,
                                        minlength = x$x.scales$minl,
                                        n = x$x.scales$tick.number)$lab


            
            if (is.character(lab)) 
                strbar <- as.list(lab)
            else if (is.expression(lab)) {
                strbar <- list() ## will contain list for max.unit data
                for (ss in seq(along = lab))
                    strbar <- c(strbar, list(lab[ss]))
            }
            else stop("Invalid value for labels")

            heights.x[5] <- 0.5 + max(0.001, x$x.scales$tck[2]) * 0.3
            ## tck = 2 is .5 lines + .6 lines
            heights.x[n.row-5] <- 0.5 + max(0.001, x$x.scales$tck[1]) * 0.3

            if (any(x.alternating==2 | x.alternating==3)) {

                if (xaxis.rot[2]  %in% c(0, 180)) {

                    heights.insertlist.position <- c(heights.insertlist.position, 4)
                    heights.insertlist.unit <-
                        unit.c(heights.insertlist.unit,
                               max(unit(rep(1.0 * xaxis.cex[2],
                                            length(strbar)), "strheight", strbar)))
                }
                else {
                    heights.insertlist.position <- c(heights.insertlist.position, 4)
                    heights.insertlist.unit <-
                        unit.c(heights.insertlist.unit,
                               max(unit(rep(1.0 * xaxis.cex[2] * abs(sin(xaxis.rot[2] * base::pi /180)),
                                            length(strbar)), "strwidth", strbar)))
                }
            }

            if (any(x.alternating==1 | x.alternating==3)) {

                if (xaxis.rot[1]  %in% c(0, 180)) {
                    
                    heights.insertlist.position <- c(heights.insertlist.position, n.row-4)
                    heights.insertlist.unit <-
                        unit.c(heights.insertlist.unit,
                               max(unit(rep(1.0 * xaxis.cex[1],
                                            length(strbar)), "strheight", strbar)))
                }

                else {

                    heights.insertlist.position <- c(heights.insertlist.position, n.row-4)
                    heights.insertlist.unit <-
                        unit.c(heights.insertlist.unit,
                               max(unit(rep(1.0 * xaxis.cex[1] * abs(sin(xaxis.rot[1] * base::pi /180)),
                                            length(strbar)), "strwidth", strbar)))
                }
            }
        }
        else { # relation != same


            ## Basically need to allocate space for the tick labels.
            ## Technically, could have different heights for different
            ## rows, but don't want to go there (probably won't look
            ## good anyway). So, boils down to finding all the
            ## labels. If at is a list, have to go through all (for
            ## each panel). If not, still have to go through
            ## all. Could save some work if at is explicitly
            ## specified, but ignoring that for now.


            labelChars <- character(0)
            labelExprs <- expression(0)
            for (i in seq(along = x$x.limits)) {
                lab <-
                    calculateAxisComponents(x = x$x.limits[[i]],
                                            at = if (is.list(x$x.scales$at)) x$x.scales$at[[i]] else x$x.scales$at,
                                            labels = if (is.list(x$x.scales$lab)) x$x.scales$lab[[i]] else x$x.scales$lab,
                                            have.log = have.xlog,
                                            logbase = xlogbase,
                                            logpaste = xlogpaste,
                                            abbreviate = x$x.scales$abbr,
                                            minlength = x$x.scales$minl,
                                            n = x$x.scales$tick.number)$lab
                if (is.character(lab)) 
                    labelChars <- c(labelChars, lab)
                else if (is.expression(lab))
                    labelExprs <- c(labelExprs, lab)
            }
            labelChars <- unique(labelChars)

            strbar <- list() ## will contain list for max.unit data
            for (ss in labelChars)
                strbar <- c(strbar, list(ss))
            for (ss in seq(along = labelExprs))
                strbar <- c(strbar, list(labelExprs[ss]))

            if (xaxis.rot[1] %in% c(0, 180)) {

                heights.x[number.of.cond + 7 + (1:rows.per.page - 1)*(number.of.cond+4)] <-
                    max(0.001, x$x.scales$tck[1]) * 0.3  ## tck = 1 -- 0.3 lines

                heights.insertlist.position <-
                    c(heights.insertlist.position,
                      number.of.cond + 8 + (1:rows.per.page - 1)*(number.of.cond+4))
                for (i in 1:rows.per.page)
                    heights.insertlist.unit <-
                        unit.c(heights.insertlist.unit,
                               max(unit(rep(1.5 * xaxis.cex[1],
                                            length(strbar)), "strheight", strbar)))

            }
            else {

                heights.x[number.of.cond + 7 + (1:rows.per.page - 1)*(number.of.cond+4)] <-
                    max(0.001, x$x.scales$tck[1]) * 0.3

                ##if (is.logical(x$x.scales$at)) {
                ##    heights.x[number.of.cond + 8 + (1:rows.per.page - 1)*(number.of.cond+4)] <-
                ##        1.1 * xaxis.cex * abs(sin(xaxis.rot * pi /180))
                ##    heights.units[number.of.cond + 8 + (1:rows.per.page - 1)*(number.of.cond+4)] <- "strwidth"
                ##    heights.data[number.of.cond + 8 + (1:rows.per.page - 1)*(number.of.cond+4)] <- which.name
                ##}
                ##else {
                heights.insertlist.position <-
                    c(heights.insertlist.position,
                      number.of.cond + 8 + (1:rows.per.page - 1)*(number.of.cond+4))
                for (i in 1:rows.per.page)
                    heights.insertlist.unit <-
                        unit.c(heights.insertlist.unit,
                               max(unit(rep(1.5 * xaxis.cex[1] * abs(sin(xaxis.rot[1] * base::pi /180)),
                                            length(strbar)), "strwidth", strbar)))
                ##}
            }
        }
    }

    heights.x[n.row-3] <- if (have.xlab) 2 * x$xlab$cex else 0 # xlab
    if (have.xlab) {
        heights.units[n.row-3] <-  "strheight"
        heights.data[[n.row-3]] <- x$xlab$lab
    }

    ## this is if strip=F -- strips not to be drawn
    for(crr in 1:number.of.cond)
        heights.x[number.of.cond + 6 + (1:rows.per.page - 1)*(number.of.cond+4) - crr] <-
            if (is.logical(x$strip)) 0  # which means strip = F, strips not to be drawn
            else 1.1 * x$par.strip.text$cex * x$par.strip.text$lines

    ## fine tuning widths:
    ##----------------------------------------------------------------------------------

    widths.x[3] <- if (have.ylab) 2 * x$ylab$cex else 0 # ylab
    if (have.ylab) {
        widths.units[3] <-  "strheight"
        widths.data[[3]] <- x$ylab$lab
    }


    widths.x[(1:cols.per.page - 1)*4 + 8] <-
        panel.width[[1]] # for the panels
    widths.units[(1:cols.per.page - 1)*4 + 8] <-
        panel.width[[2]] # for the panels
    ## was "null"


    widths.x[(1:cols.per.page - 1)*4 + 7] <- 0
    widths.x[(1:cols.per.page - 1)*4 + 6] <- 0
    ## For y-axes labels and ticks to the left of each panel when relation != "same"
    ## (might change later)

    widths.x[4] <- 0
    widths.x[5] <- 0 #ticks/labels
    widths.x[n.col-2] <- 0
    widths.x[n.col-3] <- 0

    if (cols.per.page > 1)
        widths.x[(1:(cols.per.page-1) - 1)*4 + 9] <- x.between
    ## x-between

    widths.x[1] <- 0.5
    widths.x[n.col] <- 0.5
    widths.x[2] <- 0 # key - left
    widths.x[n.col-1] <- 0 # key - right

    ## next part of the code decides how much space to leave for y
    ## tick-labels. This wasn't that bad earlier, but has become
    ## complicated to support expression-style labels. Not sure if
    ## there's a better way (would definitely need a lot of
    ## redesigning), something to look at later.

    widths.insertlist.position <- 0
    widths.insertlist.unit <- unit(1, "null")
    ## both these dummies, since there is no unit(numeric(0)). These
    ## are necessary for calculating space for axis
    ## labels. Unfortunately this makes the code complicated

    if (x$y.scales$draw) {
        
        if (y.relation.same) {

            lab <- 
                calculateAxisComponents(x = x$y.limits,
                                        at = x$y.scales$at,
                                        labels = x$y.scales$lab,
                                        have.log = have.ylog,
                                        logbase = ylogbase,
                                        logpaste = ylogpaste,
                                        abbreviate = x$y.scales$abbr,
                                        minlength = x$y.scales$minl,
                                        n = x$y.scales$tick.number)$lab


            if (is.character(lab)) 
                strbar <- as.list(lab)
            else if (is.expression(lab)) {
                strbar <- list() ## will contain list for max.unit data
                for (ss in seq(along = lab))
                    strbar <- c(strbar, list(lab[ss]))
            }
            else {
                stop("Invalid value for labels")
            }

            widths.x[5] <- 0.5 + max(0.001, x$y.scales$tck[1]) * 0.3
            ## tck = 2 is .5 lines + .6 lines
            widths.x[n.col-3] <- max(1, x$y.scales$tck[2]) * 0.5

            if (any(y.alternating==1 | y.alternating==3)) {

                if (abs(yaxis.rot[1]) == 90) {

                    widths.insertlist.position <- c(widths.insertlist.position, 4)
                    widths.insertlist.unit <-
                        unit.c(widths.insertlist.unit,
                               max(unit(1.0 * rep(yaxis.cex[1],
                                                  length(strbar)), "strheight", data = strbar)))
                }
                
                else {

                    widths.insertlist.position <- c(widths.insertlist.position, 4)
                    widths.insertlist.unit <-
                        unit.c(widths.insertlist.unit,
                               max(unit(rep(1.0 * yaxis.cex[1] * abs(cos(yaxis.rot[1] * base::pi /180)),
                                            length(strbar)), "strwidth", strbar)))
                }
            }

            if (any(y.alternating==2 | y.alternating==3)) {

                if (abs(yaxis.rot[2]) == 90) {
                    widths.insertlist.position <- c(widths.insertlist.position, n.col-2)
                    widths.insertlist.unit <-
                        unit.c(widths.insertlist.unit,
                               max(unit(rep(1.0 * yaxis.cex[2],
                                            length(strbar)), "strheight", strbar)))
                }

                else {
                    widths.insertlist.position <- c(widths.insertlist.position, n.col-2)
                    widths.insertlist.unit <-
                        unit.c(widths.insertlist.unit,
                               max(unit(rep(1.0 * yaxis.cex[2] * abs(cos(yaxis.rot[2] * base::pi /180)),
                                            length(strbar)), "strwidth", strbar)))
                    
                }
            }
        }
        else { # relation != same

            ## See comments for x-scales above
            
            labelChars <- character(0)
            labelExprs <- expression(0)
            for (i in seq(along = x$y.limits)) {
                lab <-
                    calculateAxisComponents(x = x$y.limits[[i]],
                                            at = if (is.list(x$y.scales$at)) x$y.scales$at[[i]] else x$y.scales$at,
                                            labels = if (is.list(x$y.scales$lab)) x$y.scales$lab[[i]] else x$y.scales$lab,
                                            have.log = have.ylog,
                                            logbase = ylogbase,
                                            logpaste = ylogpaste,
                                            abbreviate = x$y.scales$abbr,
                                            minlength = x$y.scales$minl,
                                            n = x$y.scales$tick.number)$lab
                if (is.character(lab)) 
                    labelChars <- c(labelChars, lab)
                else if (is.expression(lab))
                    labelExprs <- c(labelExprs, lab)
            }
            labelChars <- unique(labelChars)

            strbar <- list() ## will contain list for max.unit data
            for (ss in labelChars)
                strbar <- c(strbar, list(ss))
            for (ss in seq(along = labelExprs))
                strbar <- c(strbar, list(labelExprs[ss]))


            if (abs(yaxis.rot[1]) == 90) {

                widths.x[(1:cols.per.page - 1)*4 + 7] <- 
                    max(0.001, x$y.scales$tck[1]) * 0.3  ## tck = 1 -- 0.3 lines

                widths.insertlist.position <-
                    c(widths.insertlist.position,
                      (1:cols.per.page - 1) * 4 + 6)
                for (i in 1:cols.per.page)
                    widths.insertlist.unit <-
                        unit.c(widths.insertlist.unit,
                               max(unit(rep(1.5 * yaxis.cex[1],
                                            length(strbar)), "strheight", strbar)))

            }
            else {

                widths.x[(1:cols.per.page - 1)*4 + 7] <- 
                    max(0.001, x$y.scales$tck[1]) * 0.3

                ##if (is.logical(x$y.scales$at)) {
                ##    widths.x[(1:cols.per.page - 1)*4 + 6] <-
                ##        1.1 * yaxis.cex * abs(cos(yaxis.rot * pi /180))
                ##    widths.units[(1:cols.per.page - 1)*4 + 6] <- "strwidth"
                ##    widths.data[(1:cols.per.page - 1)*4 + 6] <- which.name
                #3}
                ##else {
                widths.insertlist.position <-
                    c(widths.insertlist.position, (1:cols.per.page - 1)*4 + 6)
                for (i in 1:cols.per.page)
                    widths.insertlist.unit <-
                        unit.c(widths.insertlist.unit,
                               max(unit(rep(1.2 * yaxis.cex[1] * abs(cos(yaxis.rot[1] * base::pi /180)),
                                            length(strbar)), "strwidth", strbar)))
                ##}
            }
        }
    }


    if (!is.null(x$key) || !is.null(x$colorkey)) {
            
        if (key.space == "left") {
            widths.x[2] <- 1.2
            widths.units[2] <- "grobwidth"
            widths.data[[2]] <- key.gf
        }
        else if (key.space == "right") {
            widths.x[n.col-1] <- 1.2
            widths.units[n.col-1] <- "grobwidth"
            widths.data[[n.col-1]] <- key.gf
        }
        else if (key.space == "top") {
            heights.x[3] <- 1.2
            heights.units[3] <- "grobheight"
            heights.data[[3]] <- key.gf
        }
        else if (key.space == "bottom") {
            heights.x[n.row-2] <- 1.2
            heights.units[n.row-2] <- "grobheight"
            heights.data[[n.row-2]] <- key.gf
        }
        
    }
    

    ## Constructing the layout:

    layout.heights <- unit(heights.x, heights.units, data=heights.data)
    if (length(heights.insertlist.position)>1)
        for (indx in 2:length(heights.insertlist.position))
            layout.heights <-
                rearrangeUnit(layout.heights, heights.insertlist.position[indx],
                              heights.insertlist.unit[indx])
    

    layout.widths <- unit(widths.x, widths.units, data=widths.data)
    if (length(widths.insertlist.position)>1)
        for (indx in 2:length(widths.insertlist.position))
            layout.widths <-
                rearrangeUnit(layout.widths, widths.insertlist.position[indx],
                              widths.insertlist.unit[indx])
    
    page.layout <- grid.layout(nrow = n.row, ncol = n.col,
                               widths = layout.widths,
                               heights = layout.heights,
                               respect = layout.respect)

        
    cond.current.level <- rep(1,number.of.cond)
    panel.number <- 1
        
    for(page.number in 1:number.of.pages)
        if (!any(cond.max.level-cond.current.level<0)) {
                
            if(usual) {
                if (new) grid.newpage()
                grid.rect(gp = gpar(fill = bg, col = "transparent"))
                new <- TRUE
            }

            push.viewport(viewport(layout = page.layout,
                                   gp = gpar(fontsize = fontsize.default,
                                   col = axis.line$col,
                                   lty = axis.line$lty,
                                   lwd = axis.line$lwd)))

            if (have.main)
                grid.text(label = x$main$label,
                          gp = gpar(col = x$main$col, font = x$main$font, 
                          fontsize = fontsize.default * x$main$cex),
                          vp = viewport(layout.pos.row = 2))
                    
                    
            if (have.sub)
                grid.text(label = x$sub$label,
                          gp = gpar(col = x$sub$col, font = x$sub$font, 
                          fontsize = fontsize.default * x$sub$cex),
                          vp = viewport(layout.pos.row = n.row-1))
                    
                    
            if (have.xlab) 
                grid.text(label = x$xlab$label,
                          gp = gpar(col = x$xlab$col, font = x$xlab$font, 
                          fontsize = fontsize.default * x$xlab$cex), 
                          vp = viewport(layout.pos.row = n.row - 3, layout.pos.col = c(6, n.col - 4)))
                
            if (have.ylab)
                grid.text(label = x$ylab$label, rot = 90,
                          gp = gpar(col = x$ylab$col, font = x$ylab$font, 
                          fontsize = fontsize.default * x$ylab$cex),
                          vp = viewport(layout.pos.col = 3, layout.pos.row = c(6, n.row - 6)))
            
            for (row in 1:rows.per.page)
                for (column in 1:cols.per.page)

                    if (!any(cond.max.level-cond.current.level<0) &&
                        (row-1) * cols.per.page + column <= plots.per.page) {

                        if (!is.list(x$panel.args[[panel.number]]))
                            ## corr to skip = T or extra plots
                            panel.number <- panel.number + 1
                            
                        else {
                                
                            actual.row <- if (x$as.table)
                                (rows.per.page-row+1) else row
                            ## this gives the row position from the bottom


                            pos.row <- 6 + number.of.cond + 
                                (rows.per.page - actual.row) *
                                (number.of.cond + 4)
                            pos.col <- (column-1) * 4 + 8


                            xlabelinfo <-
                                calculateAxisComponents(x =
                                                        if (x.relation.same) x$x.limits
                                                        else x$x.limits[[panel.number]],
                                                        at =
                                                        if (is.list(x$x.scales$at)) x$x.scales$at[[panel.number]]
                                                        else x$x.scales$at,
                                                        labels =
                                                        if (is.list(x$x.scales$lab)) x$x.scales$lab[[panel.number]]
                                                        else x$x.scales$lab,
                                                        have.log = have.xlog,
                                                        logbase = xlogbase,
                                                        logpaste = xlogpaste,
                                                        abbreviate = x$x.scales$abbr,
                                                        minlength = x$x.scales$minl,
                                                        n = x$x.scales$tick.number)

                            ylabelinfo <-
                                calculateAxisComponents(x =
                                                        if (y.relation.same) x$y.limits
                                                        else x$y.limits[[panel.number]],
                                                        at =
                                                        if (is.list(x$y.scales$at)) x$y.scales$at[[panel.number]]
                                                        else x$y.scales$at,
                                                        labels =
                                                        if (is.list(x$y.scales$lab)) x$y.scales$lab[[panel.number]]
                                                        else x$y.scales$lab,
                                                        have.log = have.ylog,
                                                        logbase = ylogbase,
                                                        logpaste = ylogpaste,
                                                        abbreviate = x$y.scales$abbr,
                                                        minlength = x$y.scales$minl,
                                                        n = x$y.scales$tick.number)



                            xscale <- xlabelinfo$num.limit
                            yscale <- ylabelinfo$num.limit
                                
                            push.viewport(viewport(layout.pos.row = pos.row,
                                                   layout.pos.col = pos.col,
                                                   xscale = xscale,
                                                   yscale = yscale,
                                                   clip = trellis.par.get("clip")$panel,
                                                   gp = gpar(fontsize =
                                                   fontsize.default)))


                            pargs <- c(x$panel.args[[panel.number]],
                                       x$panel.args.common,
                                       list(panel.number = panel.number))
                            if (!("..." %in% names(formals(panel))))
                                pargs <- pargs[names(formals(panel))]
                            do.call("panel", pargs)

                            grid.rect()

                            pop.viewport()

                            ## next few lines deal with drawing axes
                            ## as appropriate

                            ## when relation != same, axes drawn for
                            ## each panel:
                            
                            ## X-axis
                            if (!x.relation.same && x$x.scales$draw) {

                                axs <- x$x.scales

                                #if (is.logical(axs$at)) {
                                #    axs$at <- lpretty(xscale, n = axs$tick.number)
                                #    axs$labels <- paste(xlogpaste, as.character(axs$at), sep = "")
                                #}

                                ok <- (xlabelinfo$at>=xscale[1] & xlabelinfo$at<=xscale[2])

                                push.viewport(viewport(layout.pos.row = pos.row+1,
                                                       layout.pos.col = pos.col,
                                                       xscale = xscale))

                                
                                ##panel.fill(col = "yellow")
                                if (axs$tck[1] !=0 && any(ok))
                                    grid.segments(y0 = unit(rep(1, sum(ok)), "npc"),
                                                  y1 = unit(rep(1, sum(ok)), "npc") -
                                                  unit(rep(0.3 * axs$tck[1], sum(ok)), "lines"),
                                                  x0 = unit(xlabelinfo$at[ok], "native"),
                                                  x1 = unit(xlabelinfo$at[ok], "native"),
                                                  gp = gpar(col = xaxis.col))

                                # deepayan

                                pop.viewport()

                                if (any(ok))
                                    grid.text(label = xlabelinfo$label[ok],
                                              x = unit(xlabelinfo$at[ok], "native"),
                                              y = unit(if (xaxis.rot[1] %in% c(0, 180)) .5 else .95, "npc"),
                                              ##y = unit(.95, "npc"),
                                              just = if (xaxis.rot[1] == 0) c("centre", "centre")
                                              else if (xaxis.rot[1] == 180) c("centre", "centre")
                                              else if (xaxis.rot[1] > 0)  c("right", "centre")
                                              else c("left", "centre"),
                                              rot = xaxis.rot[1],
                                              check.overlap = xlabelinfo$check.overlap,
                                              gp = gpar(col = xaxis.col, font = xaxis.font, 
                                              fontsize = axs$cex[1] * fontsize.default),
                                              vp = viewport(layout.pos.row = pos.row+2,
                                              layout.pos.col = pos.col, xscale = xscale))

                            }
                            ## Y-axis
                            if (!y.relation.same && x$y.scales$draw) {

                                axs <- x$y.scales

                                #if (is.logical(axs$at)) {
                                #    axs$at <- lpretty(yscale, n = axs$tick.number)
                                #    axs$labels <- paste(ylogpaste, as.character(axs$at), sep = "")
                                #}

                                ok <- (ylabelinfo$at>=yscale[1] & ylabelinfo$at<=yscale[2])

                                push.viewport(viewport(layout.pos.row = pos.row,
                                                       layout.pos.col = pos.col-1,
                                                       yscale = yscale))


                                if (axs$tck[1] !=0 && any(ok))
                                    grid.segments(x0 = unit(rep(1, sum(ok)), "npc"),
                                                  x1 = unit(rep(1, sum(ok)), "npc") -
                                                  unit(rep(0.3 * axs$tck[1], sum(ok)), "lines"),
                                                  y0 = unit(ylabelinfo$at[ok], "native"),
                                                  y1 = unit(ylabelinfo$at[ok], "native"),
                                                  gp = gpar(col = yaxis.col))

                                pop.viewport()


                                if (any(ok))
                                    grid.text(label = ylabelinfo$label[ok],
                                              y = unit(ylabelinfo$at[ok], "native"),
                                              x = unit(if ( abs(yaxis.rot[1]) == 90) .5 else .95, "npc"),
                                              ##y = unit(.95, "npc"),
                                              just = if (yaxis.rot[1] == 90) c("centre", "centre")
                                              else if (yaxis.rot[1] == -90) c("centre", "centre")
                                              else if (yaxis.rot[1] > -90 && yaxis.rot[1] < 90) c("right", "centre")
                                              else c("left", "centre"),
                                              rot = yaxis.rot[1],
                                              check.overlap = ylabelinfo$check.overlap,
                                              gp = gpar(col = yaxis.col, font = xaxis.font, 
                                              fontsize = axs$cex[1] * fontsize.default),
                                              vp = viewport(layout.pos.row = pos.row,
                                              layout.pos.col = pos.col-2, yscale = yscale))

                            }

                            ## When relation = same, axes drawn based on value of alternating
                            if (y.relation.same && x$y.scales$draw) {
                                
                                ## Y-axis to the left
                                if (column == 1) {

                                    axs <- x$y.scales

                                    ok <- (ylabelinfo$at>=yscale[1] & ylabelinfo$at<=yscale[2])

                                    push.viewport(viewport(layout.pos.row = pos.row,
                                                           layout.pos.col = pos.col-3,
                                                           yscale = yscale))

                                    if (axs$tck[1] !=0 && any(ok))
                                        grid.segments(x0 = unit(rep(1, sum(ok)), "npc"),
                                                      x1 = unit(rep(1, sum(ok)), "npc") -
                                                      unit(rep(0.3 * axs$tck[1], sum(ok)), "lines"),
                                                      y0 = unit(ylabelinfo$at[ok], "native"),
                                                      y1 = unit(ylabelinfo$at[ok], "native"),
                                                      gp = gpar(col = yaxis.col))

                                    pop.viewport()

                                    if (y.alternating[actual.row]==1 || y.alternating[actual.row]==3) 

                                        if (any(ok)) 

                                            grid.text(label = ylabelinfo$lab[ok],
                                                      y = unit(ylabelinfo$at[ok], "native"),
                                                      x = unit(if (abs(yaxis.rot[1]) == 90) .5 else 1, "npc"),
                                                      ##y = unit(rep(.95, sum(ok)), "npc"),
                                                      just = if (yaxis.rot[1] == -90) c("centre", "centre")
                                                      else if (yaxis.rot[1] == 90) c("centre", "centre")
                                                      else if (yaxis.rot[1] > -90 && yaxis.rot[1] < 90)  c("right", "centre")
                                                      else c("left", "centre"),
                                                      rot = yaxis.rot[1],
                                                      check.overlap = ylabelinfo$check.overlap,
                                                      gp = gpar(col = yaxis.col, font = yaxis.font, 
                                                      fontsize = axs$cex[1] * fontsize.default),
                                                      vp = viewport(layout.pos.row = pos.row,
                                                      layout.pos.col = pos.col-4, yscale = yscale))

                                }


                                ## Y-axis to the right
                                if (column == cols.per.page) {

                                    axs <- x$y.scales

                                    ok <- (ylabelinfo$at>=yscale[1] & ylabelinfo$at<=yscale[2])

                                    push.viewport(viewport(layout.pos.row = pos.row,
                                                           layout.pos.col = pos.col+1,
                                                           yscale = yscale))


                                    if (axs$tck[2] !=0 && any(ok))
                                        grid.segments(x0 = unit(rep(0, sum(ok)), "npc"),
                                                      x1 = unit(rep(0.3 * axs$tck[2], sum(ok)), "lines"),
                                                      y0 = unit(ylabelinfo$at[ok], "native"),
                                                      y1 = unit(ylabelinfo$at[ok], "native"),
                                                      gp = gpar(col = yaxis.col))

                                    pop.viewport()

                                    if (y.alternating[actual.row]==2 || y.alternating[actual.row]==3)

                                        if (any(ok))

                                            grid.text(label = ylabelinfo$label[ok],
                                                      y = unit(ylabelinfo$at[ok], "native"),
                                                      x = unit(if (abs(yaxis.rot[2]) == 90) .5 else 0, "npc"),
                                                      ##y = unit(.05, "npc"),
                                                      just = if (yaxis.rot[2] == -90) c("centre", "centre")
                                                      else if (yaxis.rot[2] == 90) c("centre", "centre")
                                                      else if (yaxis.rot[2] > -90 && yaxis.rot[2] < 90)  c("left", "centre")
                                                      else c("right", "centre"),
                                                      rot = yaxis.rot[2],
                                                      check.overlap = ylabelinfo$check.overlap,
                                                      gp = gpar(col = yaxis.col, font = yaxis.font, 
                                                      fontsize = axs$cex[2] * fontsize.default),
                                                      vp = viewport(layout.pos.row = pos.row,
                                                      layout.pos.col = pos.col+2, yscale = yscale))

                                }
                            }
                                
                            ## X-axis to the bottom
                            if (x.relation.same && x$x.scales$draw) {

                                if (actual.row == 1) {

                                    axs <- x$x.scales

                                    ok <- (xlabelinfo$at>=xscale[1] & xlabelinfo$at<=xscale[2])

                                    push.viewport(viewport(layout.pos.row = pos.row+3,
                                                           layout.pos.col = pos.col,
                                                           xscale = xscale))

                                    if (axs$tck[1] !=0 && any(ok))
                                        grid.segments(y0 = unit(rep(1, sum(ok)), "npc"),
                                                      y1 = unit(rep(1, sum(ok)), "npc") -
                                                      unit(rep(0.3 * axs$tck[1], sum(ok)), "lines"),
                                                      x0 = unit(xlabelinfo$at[ok], "native"),
                                                      x1 = unit(xlabelinfo$at[ok], "native"),
                                                      gp = gpar(col = xaxis.col))

                                    pop.viewport()

                                    if (x.alternating[column]==1 || x.alternating[column]==3) 

                                        if (any(ok)) {

                                            grid.text(label = xlabelinfo$lab[ok],
                                                      x = unit(xlabelinfo$at[ok], "native"),
                                                      y = unit(if (xaxis.rot[1] %in% c(0, 180)) .5 else 1, "npc"),
                                                      ##y = unit(rep(.95, sum(ok)), "npc"),
                                                      just = if (xaxis.rot[1] == 0) c("centre", "centre")
                                                      else if (xaxis.rot[1] == 180) c("centre", "centre")
                                                      else if (xaxis.rot[1] > 0)  c("right", "centre")
                                                      else c("left", "centre"),
                                                      rot = xaxis.rot[1],
                                                      check.overlap = xlabelinfo$check.overlap,
                                                      gp = gpar(col = xaxis.col, font = xaxis.font, 
                                                      fontsize = axs$cex[1] * fontsize.default),
                                                      vp = viewport(layout.pos.row = pos.row + 4,
                                                      layout.pos.col = pos.col, xscale = xscale))
                                        }
                                }
                            }
                                    
                            ##-------------------------


                            if (!is.logical(x$strip)) # logical ==> FALSE
                                for(i in 1:number.of.cond)
                                {
                                    push.viewport(viewport(layout.pos.row = pos.row-i,
                                                           layout.pos.col = pos.col,
                                                           clip = trellis.par.get("clip")$strip,
                                                           gp = gpar(fontsize = fontsize.default)))
                                    
                                    grid.rect()
                                    x$strip(which.given = i,
                                            which.panel = cond.current.level,
                                            var.name = names(x$cond),
                                            factor.levels = if (!is.list(x$cond[[i]]))
                                            x$cond[[i]] else NULL,
                                            shingle.intervals = if (is.list(x$cond[[i]]))
                                            do.call("rbind", x$cond[[i]]) else NULL,
                                            ##x = x$condlevel[[i]],
                                            ##level = cond.current.level[i],
                                            ##name = names(x$cond)[i],
                                            bg = strip.col.default.bg[i],
                                            fg = strip.col.default.fg[i],
                                            par.strip.text = x$par.strip.text)
                                    
                                    pop.viewport()
                                            
                                }
                            
                            
                            ## X-axis at top
                            if (x.relation.same && x$x.scales$draw)

                                if (actual.row == rows.per.page) {

                                    axs <- x$x.scales

                                    ok <- (xlabelinfo$at>=xscale[1] & xlabelinfo$at<=xscale[2])

                                    push.viewport(viewport(layout.pos.row = pos.row - 1 - 
                                                           number.of.cond,
                                                           layout.pos.col = pos.col,
                                                           xscale = xscale))

                                    if (axs$tck[2] !=0 && any(ok))
                                        grid.segments(y0 = unit(rep(0, sum(ok)), "npc"),
                                                      y1 = unit(rep(0.3 * axs$tck[2], sum(ok)), "lines"),
                                                      x0 = unit(xlabelinfo$at[ok], "native"),
                                                      x1 = unit(xlabelinfo$at[ok], "native"),
                                                      gp = gpar(col = xaxis.col))

                                    pop.viewport()

                                    if (x.alternating[column]==2 || x.alternating[column]==3)

                                        if (any(ok))

                                            grid.text(label = xlabelinfo$label[ok],
                                                      x = unit(xlabelinfo$at[ok], "native"),
                                                      y = unit(if (xaxis.rot[2] %in% c(0, 180)) .5 else 0, "npc"),
                                                      ##y = unit(.05, "npc"),
                                                      just = if (xaxis.rot[2] == 0) c("centre", "centre")
                                                      else if (xaxis.rot[2] == 180) c("centre", "centre")
                                                      else if (xaxis.rot[2] > 0)  c("left", "centre")
                                                      else c("right", "centre"),
                                                      rot = xaxis.rot[2],
                                                      check.overlap = xlabelinfo$check.overlap,
                                                      gp = gpar(col = xaxis.col, font = xaxis.font, 
                                                      fontsize = axs$cex[2] * fontsize.default),
                                                      vp = viewport(layout.pos.row = pos.row - 2 - 
                                                      number.of.cond, layout.pos.col = pos.col, xscale = xscale))


                                }

                                
                            cond.current.level <- cupdate(cond.current.level,
                                                          cond.max.level)
                            panel.number <- panel.number + 1

                        }
                        
                    }
            
            
            if (!is.null(x$key) || !is.null(x$colorkey)) {
                
                if (key.space == "left") {
                    push.viewport(viewport(layout.pos.col = 2,
                                  layout.pos.row = c(6, n.row-6)))
                    grid.draw(key.gf)
                    pop.viewport()
                }
                else if (key.space == "right") {
                    push.viewport(viewport(layout.pos.col = n.col-1,
                                  layout.pos.row = c(6, n.row-6)))
                    grid.draw(key.gf)
                    pop.viewport()
                    }
                else if (key.space == "top") {
                    push.viewport(viewport(layout.pos.row = 3,
                                           layout.pos.col = c(6,n.col-4)))
                    grid.draw(key.gf)
                    pop.viewport()
                }
                else if (key.space == "bottom") {
                    push.viewport(viewport(layout.pos.row = n.row - 2,
                                           layout.pos.col = c(6,n.col-4)))
                    grid.draw(key.gf)
                    pop.viewport()
                }
                else if (key.space == "inside") {
                    
                    push.viewport(viewport(layout.pos.row = c(1, n.row),
                                           layout.pos.col = c(1, n.col)))
                    
                    if (is.null(x$key$corner)) x$key$corner <- c(0,1)
                    if (is.null(x$key$x)) x$key$x <- x$key$corner[1]
                    if (is.null(x$key$y)) x$key$y <- x$key$corner[2]
                    
                    if (all(x$key$corner == c(0,1))) {
                        
                        push.viewport(viewport(layout = grid.layout(nrow = 3, ncol = 3,
                                               widths = unit(c(x$key$x, 1, 1),
                                               c("npc", "grobwidth", "null"),
                                               list(1, key.gf, 1)),
                                               heights = unit(c(1-x$key$y, 1, 1),
                                               c("npc", "grobheight", "null"),
                                               list(1, key.gf, 1)))))
                        
                        push.viewport(viewport(layout.pos.row = 2, layout.pos.col = 2))
                        
                        grid.draw(key.gf)
                        
                        pop.viewport()
                        pop.viewport()
                        
                    }
                    
                    
                    if (all(x$key$corner == c(1,1))) {
                        
                        push.viewport(viewport(layout = grid.layout(nrow = 3, ncol = 3,
                                               heights = unit(c(1-x$key$y, 1, 1),
                                               c("npc", "grobheight", "null"),
                                               list(1, key.gf, 1)),
                                               widths = unit(c(1, 1, 1-x$key$x),
                                               c("null", "grobwidth", "npc"),
                                               list(1, key.gf, 1)))))
                        
                        push.viewport(viewport(layout.pos.row = 2, layout.pos.col = 2))
                        
                        grid.draw(key.gf)

                        pop.viewport()
                        pop.viewport()
                        
                    }
                    

                    if (all(x$key$corner == c(0,0))) {
                    
                        push.viewport(viewport(layout = grid.layout(nrow = 3, ncol = 3,
                                               widths = unit(c(x$key$x, 1, 1),
                                               c("npc", "grobwidth", "null"),
                                               list(1, key.gf, 1)),
                                               heights = unit(c(1,1,x$key$y),
                                               c("null", "grobheight", "npc"),
                                               list(1, key.gf, 1)))))
                        
                        push.viewport(viewport(layout.pos.row = 2, layout.pos.col = 2))
                        
                        grid.draw(key.gf)
                        
                        pop.viewport()
                        pop.viewport()
                        
                    }
                    
                    
                    if (all(x$key$corner == c(1,0))) {
                            
                        push.viewport(viewport(layout=grid.layout(nrow = 3, ncol = 3,
                                               widths = unit(c(1, 1, 1-x$key$x),
                                               c("null", "grobwidth", "npc"),
                                               list(1, key.gf, 1)),
                                               heights = unit(c(1, 1, x$key$y),
                                               c("null", "grobheight", "npc"),
                                               list(1, key.gf, 1)))))
                        
                        push.viewport(viewport(layout.pos.row = 2, layout.pos.col = 2))
                        
                        grid.draw(key.gf)
                        
                        pop.viewport()
                        pop.viewport()
                        
                    }
                    
                    
                    
                    pop.viewport()
                    
                }
                
            }
            
            push.viewport(viewport(layout.pos.row = c(1, n.row),
                                   layout.pos.col = c(1, n.col)))
            if(!is.null(x$page)) x$page(page.number)                
            pop.viewport()
            
            pop.viewport()
            
            
        }

    if (!missing(position)) {
        if (!missing(split)) {
            pop.viewport()
            pop.viewport()
        }
        pop.viewport()
    }
    else if (!missing(split)) {
        pop.viewport()
        pop.viewport()
    }
    invisible(page.layout)
}



### Copyright 2001  Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA



prepanel.default.qq <-
    function(x, y, ...)
{
    if (!is.numeric(x)) x <- as.numeric(x)
    if (!is.numeric(y)) y <- as.numeric(y)

    list(xlim = range(x, y),
         ylim = range(x, y),
         dx = 1,
         dy = 1)
}




panel.qq <-
    function(...)
{
    reference.line <- trellis.par.get("reference.line")
    panel.abline(0,1,
                 col = reference.line$col,
                 lty = reference.line$lty,
                 lwd = reference.line$lwd)
    panel.xyplot(...)

}



qq <-
    function(formula,
             data = parent.frame(),
             aspect = "fill",
             layout = NULL,
             panel = "panel.qq",
             prepanel = NULL,
             scales = list(),
             strip = TRUE,
             groups = NULL,
             xlab,
             xlim,
             ylab,
             ylim,
             f.value = ppoints,
             ...,
             subscripts = !is.null(groups),
             subset = TRUE)
{

    ## dots <- eval(substitute(list(...)), data, parent.frame())
    dots <- list(...)

    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)

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

    ## Step 1: Evaluate x, y, etc. and do some preprocessing
    
    form <- latticeParseFormula(formula, data)
    cond <- form$condition
    number.of.cond <- length(cond)
    y <- form$left
    x <- form$right
    if (number.of.cond == 0) {
        strip <- FALSE
        cond <- list(as.factor(rep(1, length(x))))
        layout <- c(1,1,1)
        number.of.cond <- 1
    }

    groups <- eval(substitute(groups), data, parent.frame())
    subset <- eval(substitute(subset), data, parent.frame())
    if ("subscripts" %in% names(formals(eval(panel)))) subscripts <- TRUE
    if(subscripts) subscr <- seq(along=x)
    x <- x[subset, drop = TRUE]
    y <- y[subset, drop = TRUE]
    if (subscripts) subscr <- subscr[subset, drop = TRUE]
    
    ##x <- as.numeric(x)
    y <- as.factorOrShingle(y)
    is.f.y <- is.factor(y)
    num.l.y <- nlevels(y)
    if (num.l.y!=2) stop("y must have exactly 2 levels")

    if(missing(xlab)) xlab <-
        if (is.f.y) unique(levels(y))[1]
        else paste("y:", as.character(unique(levels(y)[[1]])))
    
    if(missing(ylab)) ylab <-
        if (is.f.y) unique(levels(y))[2]
        else paste("y:", as.character(unique(levels(y)[[2]])))


    ## create a skeleton trellis object with the
    ## less complicated components:

    foo <- do.call("trellis.skeleton",
                   c(list(aspect = aspect,
                          strip = strip,
                          panel = panel,
                          xlab = xlab,
                          ylab = ylab), dots))

    dots <- foo$dots # arguments not processed by trellis.skeleton
    foo <- foo$foo
    foo$call <- match.call()
    foo$fontsize.normal <- 10
    foo$fontsize.small <- 8

    ## This is for cases like xlab/ylab = list(cex=2)
    if (is.list(foo$xlab) && !is.characterOrExpression(foo$xlab$label))
        foo$xlab$label <-
            if (is.f.y) unique(levels(y))[1]
            else paste("y:", as.character(unique(levels(y)[[1]])))
    if (is.list(foo$ylab) && !is.characterOrExpression(foo$ylab$label))
        foo$ylab$label <-
            if (is.f.y) unique(levels(y))[y]
            else paste("y:", as.character(unique(levels(y)[[2]])))

    ## Step 2: Compute scales.common (leaving out limits for now)

    ## scales <- eval(substitute(scales), data, parent.frame())
    if (is.character(scales)) scales <- list(relation = scales)
    foo <- c(foo, 
             do.call("construct.scales", scales))


    ## Step 3: Decide if limits were specified in call:

    have.xlim <- !missing(xlim)
    if (!is.null(foo$x.scales$limit)) {
        have.xlim <- TRUE
        xlim <- foo$x.scales$limit
    }
    have.ylim <- !missing(ylim)
    if (!is.null(foo$y.scales$limit)) {
        have.ylim <- TRUE
        ylim <- foo$y.scales$limit
    }

    ## Step 4: Decide if log scales are being used: completed later

    have.xlog <- !is.logical(foo$x.scales$log) || foo$x.scales$log
    have.ylog <- !is.logical(foo$y.scales$log) || foo$y.scales$log
    if (have.xlog) {
        xlog <- foo$x.scales$log
        xbase <-
            if (is.logical(xlog)) 10
            else if (is.numeric(xlog)) xlog
            else if (xlog == "e") exp(1)

        ## x <- log(x, xbase)  later, in panel.args
        if (have.xlim) xlim <- log(xlim, xbase)
    }
    if (have.ylog) {
        ylog <- foo$y.scales$log
        ybase <-
            if (is.logical(ylog)) 10
            else if (is.numeric(ylog)) ylog
            else if (ylog == "e") exp(1)

        ## y <- log(y, ybase)
        if (have.ylim) ylim <- log(ylim, ybase)
    }
    
    ## Step 5: Process cond

    cond <- lapply(cond, as.factorOrShingle, subset, drop = TRUE)
    cond.max.level <- unlist(lapply(cond, nlevels))


    id.na <- is.na(x)|is.na(y)
    for (var in cond)
        id.na <- id.na | is.na(var)
    if (!any(!id.na)) stop("nothing to draw")
    ## Nothing simpler ?

    foo$condlevels <- lapply(cond, levels)

    ## Step 6: Evaluate layout, panel.args.common and panel.args


    foo$panel.args.common <- dots
    if (subscripts) foo$panel.args.common$groups <- groups

    layout <- compute.layout(layout, cond.max.level, skip = foo$skip)
    plots.per.page <- max(layout[1] * layout[2], layout[2])
    number.of.pages <- layout[3]
    foo$skip <- rep(foo$skip, length = plots.per.page)
    foo$layout <- layout
    nplots <- plots.per.page * number.of.pages

    foo$panel.args <- as.list(1:nplots)
    cond.current.level <- rep(1,number.of.cond)
    panel.number <- 1 # this is a counter for panel number
    for (page.number in 1:number.of.pages)
        if (!any(cond.max.level-cond.current.level<0))
            for (plot in 1:plots.per.page) {

                if (foo$skip[plot]) foo$panel.args[[panel.number]] <- FALSE
                else if(!any(cond.max.level-cond.current.level<0)) {

                    id <- !id.na
                    for(i in 1:number.of.cond)
                    {
                        var <- cond[[i]]
                        id <- id &
                        if (is.shingle(var))
                            ((var >=
                              levels(var)[[cond.current.level[i]]][1])
                             & (var <=
                                levels(var)[[cond.current.level[i]]][2]))
                        else (as.numeric(var) == cond.current.level[i])
                    }

                    if (any(id)) {

                        if (is.f.y) {
                            tx <- x[id]
                            ty <- as.numeric(y[id])
                            x.val <- tx[ty==1]
                            y.val <- tx[ty==2]
                        }
                        else {
                            tx <- x[id]
                            ty <- y[id]
                            ly <- levels(y)
                            x.val <- tx[ty>=ly[[1]][1] & ty <=ly[[1]][2]]
                            y.val <- tx[ty>=ly[[2]][1] & ty <=ly[[2]][2]]
                        }
                        n <- max(length(x.val), length(y.val))
                        p  <- f.value(n)
                        foo$panel.args[[panel.number]] <-
                            list(x = quantile(x = x.val, probs = p),
                                 y = quantile(x = y.val, probs = p))

                    }
                    else
                        foo$panel.args[[panel.number]] <-
                            list(x = numeric(0), y = numeric(0))

                    if (subscripts)
                        foo$panel.args[[panel.number]]$subscripts <-
                            subscr[id]

                    cond.current.level <-
                        cupdate(cond.current.level,
                                cond.max.level)
                }

                panel.number <- panel.number + 1
            }

    foo <- c(foo,
             limits.and.aspect(prepanel.default.qq,
                               prepanel = prepanel, 
                               have.xlim = have.xlim, xlim = xlim, 
                               have.ylim = have.ylim, ylim = ylim, 
                               x.relation = foo$x.scales$relation,
                               y.relation = foo$y.scales$relation,
                               panel.args.common = foo$panel.args.common,
                               panel.args = foo$panel.args,
                               aspect = aspect,
                               nplots = nplots,
                               x.axs = foo$x.scales$axs,
                               y.axs = foo$y.scales$axs))

    class(foo) <- "trellis"
    foo
}




### Copyright 2001  Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA




panel.qqmathline <-
    function(y, distribution, ...)
{
    y <- as.numeric(y)

    if (length(y) > 0) {
        yy <- quantile(y, c(0.25, 0.75))
        xx <- distribution(c(0.25, 0.75))
        r <- diff(yy)/diff(xx)
        panel.abline(c( yy[1]-xx[1]*r , r), ...)
    }
}


prepanel.qqmathline <-
    function(y, distribution, f.value = ppoints, ...)
{
    if (!is.numeric(y)) y <- as.numeric(y)

    yy <- quantile(y, c(0.25, 0.75))
    xx <- distribution(c(0.25, 0.75))
    n <- length(y)
    list(ylim = range(y), xlim = range(distribution(f.value(n))),
         dx = diff(xx), dy = diff(yy))
}


prepanel.default.qqmath <-
    function(...)
    prepanel.default.xyplot(...)


panel.qqmath <-
    function(...) panel.xyplot(...)


qqmath <-
    function(formula,
             data = parent.frame(),
             aspect = "fill",
             layout = NULL,
             panel = "panel.qqmath",
             prepanel = NULL,
             scales = list(),
             strip = TRUE,
             groups = NULL,
             xlab,
             xlim,
             ylab,
             ylim,
             f.value = ppoints,
             distribution = qnorm,
             ...,
             subscripts = !is.null(groups),
             subset = TRUE)
{

    ## dots <- eval(substitute(list(...)), data, parent.frame())
    dots <- list(...)

    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)

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

    distribution.name <- deparse(substitute(distribution))
    distribution <-
        if (is.function(distribution)) distribution 
        else if (is.character(distribution)) get(distribution)
        else eval(distribution)

    ## Step 1: Evaluate x, y, etc. and do some preprocessing
    
    form <- latticeParseFormula(formula, data)
    cond <- form$condition
    number.of.cond <- length(cond)
    x <- form$right
    if (number.of.cond == 0) {
        strip <- FALSE
        cond <- list(as.factor(rep(1, length(x))))
        layout <- c(1,1,1)
        number.of.cond <- 1
    }

    groups <- eval(substitute(groups), data, parent.frame())
    subset <- eval(substitute(subset), data, parent.frame())
    if ("subscripts" %in% names(formals(eval(panel)))) subscripts <- TRUE
    if(subscripts) subscr <- seq(along=x)
    x <- x[subset, drop = TRUE]
    if (subscripts) subscr <- subscr[subset, drop = TRUE]

    if(missing(ylab)) ylab <- form$right.name
    if(missing(xlab)) xlab <- distribution.name
    if (is.shingle(x)) stop("x cannot be a shingle")
    ##x <- as.numeric(x)

    ## create a skeleton trellis object with the
    ## less complicated components:

    foo <- do.call("trellis.skeleton",
                   c(list(aspect = aspect,
                          strip = strip,
                          panel = panel,
                          xlab = xlab,
                          ylab = ylab), dots))

    dots <- foo$dots # arguments not processed by trellis.skeleton
    foo <- foo$foo
    foo$call <- match.call()
    foo$fontsize.normal <- 10
    foo$fontsize.small <- 8

    ## This is for cases like xlab/ylab = list(cex=2)
    if (is.list(foo$xlab) && !is.characterOrExpression(foo$xlab$label))
        foo$xlab$label <- deparse(substitute(distribution))
    if (is.list(foo$ylab) && !is.characterOrExpression(foo$ylab$label))
        foo$ylab$label <- form$right.name

    ## Step 2: Compute scales.common (leaving out limits for now)

    ## scales <- eval(substitute(scales), data, parent.frame())
    if (is.character(scales)) scales <- list(relation = scales)
    foo <- c(foo, 
             do.call("construct.scales", scales))


    ## Step 3: Decide if limits were specified in call:

    have.xlim <- !missing(xlim)
    if (!is.null(foo$x.scales$limit)) {
        have.xlim <- TRUE
        xlim <- foo$x.scales$limit
    }
    have.ylim <- !missing(ylim)
    if (!is.null(foo$y.scales$limit)) {
        have.ylim <- TRUE
        ylim <- foo$y.scales$limit
    }

    ## Step 4: Decide if log scales are being used:

    have.xlog <- !is.logical(foo$x.scales$log) || foo$x.scales$log
    have.ylog <- !is.logical(foo$y.scales$log) || foo$y.scales$log
    if (have.xlog) {
        xlog <- foo$x.scales$log
        xbase <-
            if (is.logical(xlog)) 10
            else if (is.numeric(xlog)) xlog
            else if (xlog == "e") exp(1)

        x <- log(x, xbase)
        if (have.xlim) xlim <- log(xlim, xbase)
    }
    if (have.ylog) {
        warning("cannot use log scale for y, use different distribution")
        foo$y.scales$log <- FALSE
    }
    
    ## Step 5: Process cond

    cond <- lapply(cond, as.factorOrShingle, subset, drop = TRUE)
    cond.max.level <- unlist(lapply(cond, nlevels))


    id.na <- is.na(x)
    for (var in cond)
        id.na <- id.na | is.na(var)
    if (!any(!id.na)) stop("nothing to draw")
    ## Nothing simpler ?

    foo$condlevels <- lapply(cond, levels)

    ## Step 6: Evaluate layout, panel.args.common and panel.args

    foo$panel.args.common <- dots
    if (subscripts) foo$panel.args.common$groups <- groups

    layout <- compute.layout(layout, cond.max.level, skip = foo$skip)
    plots.per.page <- max(layout[1] * layout[2], layout[2])
    number.of.pages <- layout[3]
    foo$skip <- rep(foo$skip, length = plots.per.page)
    foo$layout <- layout
    nplots <- plots.per.page * number.of.pages

    foo$panel.args <- as.list(1:nplots)
    cond.current.level <- rep(1,number.of.cond)
    panel.number <- 1 # this is a counter for panel number
    for (page.number in 1:number.of.pages)
        if (!any(cond.max.level-cond.current.level<0))
            for (plot in 1:plots.per.page) {

                if (foo$skip[plot]) foo$panel.args[[panel.number]] <- FALSE
                else if(!any(cond.max.level-cond.current.level<0)) {

                    id <- !id.na
                    for(i in 1:number.of.cond)
                    {
                        var <- cond[[i]]
                        id <- id &
                        if (is.shingle(var))
                            ((var >=
                              levels(var)[[cond.current.level[i]]][1])
                             & (var <=
                                levels(var)[[cond.current.level[i]]][2]))
                        else (as.numeric(var) == cond.current.level[i])
                    }
                    if (any(id)) {
                        foo$panel.args[[panel.number]] <-
                            list(x = distribution(f.value(length(x[id]))), 
                                 y = quantile(x[id], f.value(length(x[id]))))
                    }
                    else
                        foo$panel.args[[panel.number]] <-
                            list(x = numeric(0), y = numeric(0))

                    if (subscripts)
                        foo$panel.args[[panel.number]]$subscripts <-
                            subscr[id]

                    cond.current.level <-
                        cupdate(cond.current.level,
                                cond.max.level)
                }

                panel.number <- panel.number + 1
            }

    foo <- c(foo,
             limits.and.aspect(prepanel.default.qqmath,
                               prepanel = prepanel, 
                               have.xlim = have.xlim, xlim = xlim, 
                               have.ylim = have.ylim, ylim = ylim, 
                               x.relation = foo$x.scales$relation,
                               y.relation = foo$y.scales$relation,
                               panel.args.common = foo$panel.args.common,
                               panel.args = foo$panel.args,
                               aspect = aspect,
                               nplots = nplots,
                               x.axs = foo$x.scales$axs,
                               y.axs = foo$y.scales$axs,
                               distribution = distribution))

    class(foo) <- "trellis"
    foo
}







rfs <-
    function(model, layout = c(2,1), xlab = "f-value", ylab = NULL,
             distribution = qunif,
             panel = function(...) {panel.grid(); panel.qqmath(...)},
             prepanel = NULL, strip = TRUE, ...)
{

    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)

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

    fitval <- fitted.values(model) - mean(fitted.values(model))
    resids <- residuals(model)
    
    nf <- length(fitval)
    nr <- length(resids)
    
    data <- list(y = c( fitval, resids),
                 f = c( rep("Fitted Values minus Mean", nf),
                 rep("Residuals", nr)))

    qqmath(~y|f, data = data, layout = layout, xlab = xlab, ylab = ylab,
           distribution = distribution, panel = panel,
           prepanel = prepanel, strip = strip, ...)
}


### Copyright 2001-2002 Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

col.whitebg <- function()
    list(background = list(col="transparent"),
         bar.fill = list(col="#c8ffc8"),
         box.rectangle = list(col="darkgreen"),
         box.umbrella = list(col="darkgreen"),
         dot.line = list(col="#e8e8e8"),
         dot.symbol = list(col="darkgreen"),
         plot.line = list(col="darkgreen"),
         plot.symbol = list(col="darkgreen"),
         ##regions=list(col=rev(hsv(h=250:349/1000, v=30:129/150,s=.5,
         ##gamma = .6)))
         regions = list(col = heat.colors(100)),
         strip.shingle = list(col = c("#ff7f00", "#00ff00", "#00ffff",
                                 "#0080ff", "#ff00ff", "#ff0000", "#ffff00")),
         strip.background = list(col = c("#ffe5cc", "#ccffcc", "#ccffff",
                                 "#cce6ff", "#ffccff", "#ffcccc", "#ffffcc")),
         reference.line = list(col="#e8e8e8"),
         superpose.line = list(col = c("darkgreen","red","royalblue",
                               "brown","orange","turquoise", "orchid"),
         lty = 1:7),
         superpose.symbol = list(pch = c(1,3,6,0,5,16,17), cex = rep(.7, 7),
         col = c("darkgreen","red","royalblue",
                                 "brown","orange","turquoise", "orchid")))


canonical.theme <- function(name = "null device", color = TRUE)
{
    ## For the purpose of this function, the only differences in the
    ## settings/themes arise from the difference in the default
    ## colors. So, I will first set up the appropriate colors
    ## according to 'name', and then use those to create the
    ## theme. The first 16 colors correspond to trellis.settings
    ## colors, the 17th is the background color.

    if (color)
    {
        ## color colors
        can.col <-
            if (name == "windows" || name == "X11")
                c("#000000", "#00ffff", "#ff00ff", "#00ff00",
                  "#ff7f00", "#007eff", "#ffff00", "#ff0000",
                  "#c6ffff", "#ffc3ff", "#c8ffc8", "#ffd18f",
                  "#a9e2ff", "#ffffc3", "#ff8c8a", "#aaaaaa",
                  "#909090")
            else if (name %in% c("postscript", "pdf", "xfig"))
                c("#000000", "#00ffff", "#ff00ff", "#00ff00",
                  "#ff7f00", "#0080ff", "#ffff00", "#ff0000",
                  "#ccffff", "#ffccff", "#ccffcc", "#ffe5cc",
                  "#cce6ff", "#ffffcc", "#ffcccc", "#e6e6e6",
                  "transparent")
            else ## default, same as X11 for now
                c("#000000", "#00FFFF", "#FF00FF", "#00FF00",
                  "#FF7F00", "#007EFF", "#FFFF00", "#FF0000",
                  "#C6FFFF", "#FFC3FF", "#C8FFC8", "#FFD18F",
                  "#A9E2FF", "#FFFFC3", "#FF8C8A", "#AAAAAA",
                  "#909090")
    }
    else ## b&w colors, same for all devices (8:16 actually unnecessary)
        can.col <-
            c("#000000", "#999999", "#4C4C4C", "#E6E6E6", "#F2F2F2",
              "#B2B2B2", "#000000", "#030303", "#050505", "#080808",
              "#0A0A0A", "#0D0D0D", "#0F0F0F", "#121212", "#151515",
              "#171717", "transparent")

    ## The following definition is the basis for what elements are
    ## valid in any setting. Adding something here should be necessary
    ## and sufficient.

    ## color settings, modified later if postscript or color = FALSE
    ans <-
        list(fontsize = list(default = 10),
             background = list(col = can.col[17]),
             clip = list(panel = TRUE, strip = TRUE),
             add.line = list(col = can.col[1], lty = 1, lwd = 1),
             add.text = list(cex = 1, col = can.col[1], font = 1),
             bar.fill = list(col = can.col[2]),
             box.dot = list(col = can.col[1], cex = 1, font = 1, pch =
             16),
             box.rectangle = list(col = can.col[2],
             fill = "transparent", lty = 1, lwd = 1),
             box.umbrella = list(col = can.col[2], lty = 2, lwd = 1),
             dot.line = list(col = can.col[16], lty = 1, lwd = 1),
             dot.symbol = list(cex = 0.8, col = can.col[2], font = 1,
             pch = 16),
             plot.line = list(col = can.col[2], lty = 1, lwd = 1),
             plot.symbol = list(cex = 0.8, col = can.col[2], font = 1,
             pch = 1),
             reference.line = list(col = can.col[16], lty = 1, lwd =
             1),
             strip.background = list(col = can.col[c(12, 11, 9, 13,
                                     10, 15, 14)]),
             strip.shingle = list(col = can.col[c(5, 4, 2, 6, 3, 8,
             7)]), superpose.line = list(col = can.col[2:8], lty =
             c(1, 1, 1, 1, 1, 1, 1), lwd = c(1, 1, 1, 1, 1, 1, 1)),
             regions = list(col = rev(cm.colors(100))),
             superpose.symbol = list(cex = c(0.8, 0.8, 0.8, 0.8, 0.8,
             0.8, 0.8), col = can.col[2:8], font = c(1, 1, 1, 1, 1, 1,
             1), pch = c("o", "o", "o", "o", "o", "o", "o")),
             axis.line = list(col = can.col[1], lty = 1, lwd = 1),
             axis.text = list(cex = .8, col = can.col[1], font = 1),
             box.3d = list(col = can.col[1], lty = 1, lwd = 1),
             par.xlab.text = list(cex = 1, col = can.col[1], font =
             1),
             par.ylab.text = list(cex = 1, col = can.col[1], font =
             1),
             par.main.text = list(cex = 1.2, col = can.col[1], font =
             2),
             par.sub.text = list(cex = 1, col = can.col[1], font = 2))

    if (color) {
        if (name == "postscript" || name == "pdf") {
            ans$plot.symbol$col <- can.col[6]
            ans$plot.line$col <- can.col[6]
            ans$dot.symbol$col <- can.col[6]
            ans$box.rectangle$col <- can.col[6]
            ans$box.umbrella$col <- can.col[6]
            ans$superpose.symbol$col <- c(can.col[c(6, 3, 4, 8)],
                                          "orange", "darkgreen", "brown")
            ans$superpose.line$col <- c(can.col[c(6, 3, 4, 8)],
                                          "orange", "darkgreen", "brown")
        }
    }
    else {
        ## black and white settings
        ans$bar.fill$col <- can.col[5]
        ans$box.dot$col <- can.col[1]
        ans$box.rectangle$col <- can.col[1]
        ans$box.umbrella$col <- can.col[1]
        ans$box.umbrella$lty <- 2
        ans$dot.line$col <- can.col[4]
        ans$dot.symbol$col <- can.col[1]
        ans$dot.symbol$cex <- 0.85
        ans$plot.line$col <- can.col[1]
        ans$plot.symbol$col <- can.col[1]
        ans$regions$col <- gray(29:128/128)
        ans$reference.line$col <- can.col[4]
        ans$strip.background$col <- can.col[rep(5, 7)]
        ans$strip.shingle$col <- can.col[rep(6, 7)]
        ans$superpose.line$col <- can.col[rep(1, 7)]
        ans$superpose.line$lty <- 1:7
        ans$superpose.symbol$col <- can.col[rep(1, 7)]
        ans$superpose.symbol$cex <- rep(0.7, 7)
        ans$superpose.symbol$pch <- c(1,3,6,0,5,16,17)
        ##ans$superpose.symbol$pch <- c("o","+",">","s","w","#","{")
    }
    ans
}   





trellis.par.get <-
    function(name = NULL)
{
    ## the default device is opened if none already open
    if (is.null(dev.list())) trellis.device()

    ## just in case settings for the current device haven't been
    ## created yet, which may happen if the device is opened by x11(),
    ## say, (i.e., not by trellis.device()) and no trellis object has
    ## been printed on this device yet:

    if (!(.Device %in% names(get("lattice.theme", envir = .LatticeEnv)))) {
        trellis.device(device = .Device, new = FALSE)
    }

    lattice.theme <- get("lattice.theme", envir = .LatticeEnv)
    if (is.null(name))
        lattice.theme[[.Device]]
    else if (name %in% names(lattice.theme[[.Device]]))
        lattice.theme[[.Device]][[name]]
    else NULL
}



trellis.par.set <-
    function(name, value, warn = TRUE)
{
    ## the default device is opened if none already open
    if (is.null(dev.list())) {
        trellis.device()
        if (warn) cat("Note: The default device has been opened to honour attempt to modify trellis settings\n\n")
    }

    ## if (name %in% names(lattice.theme[[.Device]])) NEEDED as a safeguard ?
    if (!is.list(value)) stop("value must be a list")
    lattice.theme <- get("lattice.theme", envir=.LatticeEnv)
    lattice.theme[[.Device]][[name]] <- value
    assign("lattice.theme", lattice.theme, envir=.LatticeEnv)
}



trellis.device <-
    function(device = getOption("device"),
             color = !(dev.name == "postscript"),
             theme = getOption("lattice.theme"),
             bg = NULL,
             new = TRUE,
             retain = FALSE,
             ...)
{
    ## Get device function
    if (is.character(device))
    {
        device.call <- get(device)
        dev.name <- device
    }
    else {
        device.call <- device
        dev.name <- deparse(substitute(device))
    }

    ## Start the new device if necessary.
    ## new = FALSE ignored if no devices open.
    if (new || is.null(dev.list()))
    {
        device.call(...)
        assign(".lattice.print.more", FALSE, envir = .LatticeEnv)
    }

    ## Make sure there's an entry for this device in the theme list
    lattice.theme <- get("lattice.theme", envir = .LatticeEnv)
    if (!(.Device %in% names(lattice.theme))) {
        lattice.theme[[.Device]] <- canonical.theme(name = .Device, color = color)
        assign("lattice.theme", lattice.theme, envir = .LatticeEnv)
    }

    ## If retain = FALSE, overwrite with default settings for device
    if (!retain) lset(canonical.theme(name=.Device, color=color))

    ## get theme as list
    if (!is.null(theme) && !is.list(theme)) {
        if (is.character(theme)) theme <- get(theme)
        if (is.function(theme)) theme <- theme()
        if (!is.list(theme)) {
            warning("Invalid theme specified")
            theme <- NULL
        }
    }

    ## apply theme and background
    if (!is.null(theme)) lset(theme)
    if (!is.null(bg)) lset(list(background = list(col = bg)))
    return(invisible())
}



lset <- function(theme = col.whitebg(), warn = TRUE)
{
    for (item in names(theme)) {
        foo <- trellis.par.get(item)
        bar <- theme[[item]]
        foo[names(bar)] <- bar
        trellis.par.set(item, foo, warn = warn)
    }
}







show.settings <- function(x = NULL)
{
    if (is.null(dev.list())) trellis.device()
    theme <- trellis.par.get()
    if (is.null(theme) && is.null(x)) print("No active device") ## shouldn't happen
    else {
        if (is.null(theme)) { ## also shouldn't happen
            cat("\nNo device is currently active but a theme has been explicitly specified.")
            cat("\nDefault device options will be used to fill missing components")
            cat("\nof specified theme, if any.\n")
            theme <- canonical.theme(getOption("device"))
        }
        if (!is.null(x)) {
            for (item in names(x)) {
                foo <- x[[item]]
                theme[[item]][names(foo)] <- foo
            }
        }
        n.row <- 13
        n.col <- 9
        heights.x <- rep(1, n.row)
        heights.units <- rep("lines", n.row)
        heights.units[c(2, 5, 8, 11)] <- "null"
        widths.x <- rep(1, n.row)
        widths.units <- rep("lines", n.row)
        widths.units[c(2, 4, 6, 8)] <- "null"
        page.layout <- grid.layout(nrow = n.row, ncol = n.col,
                                   widths = unit(widths.x, widths.units),
                                   heights = unit(heights.x, heights.units))
        if (!get(".lattice.print.more", envir=.LatticeEnv)) grid.newpage()
        assign(".lattice.print.more", FALSE, envir=.LatticeEnv)
        grid.rect(gp = gpar(fill = theme$background$col,
                  col = "transparent"))
        push.viewport(viewport(layout = page.layout,
                               gp = gpar(fontsize = theme$fontsize$default)))
        superpose.symbol <- theme$superpose.symbol
        len <- length(superpose.symbol$col)
        push.viewport(viewport(layout.pos.row = 2,
                               layout.pos.col = 2,
                               yscale = c(0,len+1),
                               xscale = c(0,len+1)))
        for (i in 1:len) {
            lpoints(y = rep(i, len), x = 1:len,
                    col = superpose.symbol$col[i],
                    font = superpose.symbol$font[i],
                    cex = superpose.symbol$cex[i],
                    pch = superpose.symbol$pch[i])
        }
        pop.viewport()
        grid.text(lab = "superpose.symbol",
                  ##gp = gpar(fontsize = 8),
                  vp = viewport(layout.pos.row = 3, layout.pos.col = 2))
        superpose.line <- theme$superpose.line
        len <- length(superpose.line$col)
        push.viewport(viewport(layout.pos.row = 2,
                               layout.pos.col = 4,
                               yscale = c(0,len+1),
                               xscale = c(0,1)))
        for (i in 1:len) {
            llines(y = rep(i, 2), x = c(0,1),
                   col = superpose.line$col[i],
                   lty = superpose.line$lty[i],
                   lwd = superpose.line$lwd[i])
        }
        pop.viewport()
        grid.text(lab = "superpose.line",
                  ## gp = gpar(fontsize = 8),
                  vp = viewport(layout.pos.row = 3, layout.pos.col = 4))
        strip.background <- theme$strip.background
        len <- length(strip.background$col)
        push.viewport(viewport(layout.pos.row = 2,
                               layout.pos.col = 6,
                               yscale = c(0,len+1),
                               xscale = c(0,1)))
        for (i in 1:len) {
            grid.rect(y = unit(i, "native"), h = unit(.5, "native"),
                      gp = gpar(fill = strip.background$col[i]))
        }
        pop.viewport()
        grid.text(lab = "strip.background",
                  ## gp = gpar(fontsize = 8),
                  vp = viewport(layout.pos.row = 3, layout.pos.col = 6))
        strip.shingle <- theme$strip.shingle
        len <- length(strip.shingle$col)
        push.viewport(viewport(layout.pos.row = 2,
                               layout.pos.col = 8,
                               yscale = c(0,len+1),
                               xscale = c(0,1)))
        for (i in 1:len) {
            grid.rect(y = unit(i, "native"), h = unit(.5, "native"),
                      gp = gpar(fill = strip.shingle$col[i]))
        }
        pop.viewport()
        grid.text(lab = "strip.shingle",
                  ## gp = gpar(fontsize = 8),
                  vp = viewport(layout.pos.row = 3, layout.pos.col = 8))
        push.viewport(viewport(layout.pos.row = 5,
                               layout.pos.col = 2,
                               yscale = extend.limits(c(0,6)),
                               xscale = c(0,6)))
        x <- c(1,2,3,4,5)
        dot.line <- theme$dot.line
        dot.symbol <- theme$dot.symbol
        panel.abline(h=1:5, col=dot.line$col,
                     lty=dot.line$lty, lwd=dot.line$lwd)
        panel.xyplot(x = x, y = x, col = dot.symbol$col, pch = dot.symbol$pch)
        grid.rect()
        pop.viewport()
        grid.text(lab = "dot.[symbol, line]",
                  ## gp = gpar(fontsize = 8),
                  vp = viewport(layout.pos.row = 6, layout.pos.col = 2))
        box.rectangle <- theme$box.rectangle
        box.dot <- theme$box.dot
        box.umbrella <- theme$box.umbrella
        push.viewport(viewport(layout.pos.row = 5,
                               layout.pos.col = 4,
                               yscale = c(-1.5,1.5),
                               xscale = c(0,6)))
        push.viewport(viewport(height = unit(.1, "npc")))
        grid.rect(width = 1/3, 
                  gp = gpar(lwd = box.rectangle$lwd, 
                  lty = box.rectangle$lty,
                  fill = box.rectangle$fill,
                  col = box.rectangle$col))
        grid.lines(x = unit(c(1/6, 1/3), "npc"), 
                   y = unit(c(0.5, 0.5), "npc"),
                   gp = gpar(col = box.umbrella$col,
                   lwd = box.umbrella$lwd, lty = box.umbrella$lty))
        grid.lines(x = unit(c(2/3, 5/6), "npc"), 
                   y = unit(c(0.5, 0.5), "npc"),
                   gp = gpar(col = box.umbrella$col,
                   lwd = box.umbrella$lwd, lty = box.umbrella$lty))
        grid.lines(x = unit(rep(1/6, 2), "npc"), 
                   y = unit(c(0, 1), "npc"),
                   gp = gpar(col = box.umbrella$col, 
                   lwd = box.umbrella$lwd, lty = box.umbrella$lty))
        grid.lines(x = unit(rep(5/6, 2), "npc"), 
                   y = unit(c(0, 1), "npc"),
                   gp = gpar(col = box.umbrella$col, 
                   lwd = box.umbrella$lwd, lty = box.umbrella$lty))
        if (is.character(box.dot$pch)) 
            grid.text(x = unit(0.5, "npc"), y = unit(0.5, "npc"),
                      lab = box.dot$pch,
                      gp = gpar(col = box.dot$col, cex = box.dot$cex))
        else
            grid.points(x = unit(0.5, "npc"), y = unit(0.5, "npc"),
                        pch = box.dot$pch, size = unit(box.dot$cex * 2.5, "mm"),
                        gp = gpar(col = box.dot$col))
        pop.viewport()
        grid.rect()
        pop.viewport()
        grid.text(lab = "box.[dot, rectangle, umbrella]",
                  ## gp = gpar(fontsize = 8),
                  vp = viewport(layout.pos.row = 6, layout.pos.col = 4))
        add.text <- theme$add.text
        add.line <- theme$add.line
        push.viewport(viewport(layout.pos.row = 5,
                               layout.pos.col = 6,
                               yscale = c(-1,1),
                               xscale = c(0,1)))
        x <- seq(.1, .9, length = 50)
        y <- .9 * sin(.1+11*x)
        llines(x = x, y = y, type = "l", col = add.line$col,
               lty = add.line$lty, lwd = add.line$lwd)
        grid.text(lab = c("Hello", "World"),
                  x = c(.25, .75), y = c(-.5, .5), default.units = "native",
                  gp = gpar(col = add.text$col,
                  fontsize = add.text$cex * trellis.par.get("fontsize")$default,
                  font = add.text$font))
        grid.rect()
        pop.viewport()
        grid.text(lab = "add.[line, text]",
                  ## gp = gpar(fontsize = 8),
                  vp = viewport(layout.pos.row = 6, layout.pos.col = 6))
        reference.line <- theme$reference.line
        push.viewport(viewport(layout.pos.row = 5,
                               layout.pos.col = 8,
                               yscale = c(0,4),
                               xscale = c(0,4)))
        panel.grid(col = reference.line$col,
                   lwd = reference.line$lwd,
                   lty = reference.line$lty)
        grid.rect()
        pop.viewport()
        grid.text(lab = "reference.line",
                  ## gp = gpar(fontsize = 8),
                  vp = viewport(layout.pos.row = 6, layout.pos.col = 8))
        plot.symbol <- theme$plot.symbol
        plot.line <- theme$plot.line
        push.viewport(viewport(layout.pos.row = 8,
                               layout.pos.col = 2,
                               yscale = c(-1.1,1.1),
                               xscale = c(-.1,1.1)))
        x <- seq(.1, .9, length = 20)
        y <- .9 * sin(.1+11*x)
        panel.xyplot(x = x+.05, y = y+.1, type = "l",
                     lty = plot.line$lty,
                     col = plot.line$col,
                     lwd = plot.line$lwd)
        panel.xyplot(x = x-.05, y = y-.1,
                     col = plot.symbol$col,
                     font = plot.symbol$font,
                     pch = plot.symbol$pch,
                     cex = plot.symbol$cex)
        grid.rect()
        pop.viewport()
        grid.text(lab = "plot.[symbol, line]",
                  ## gp = gpar(fontsize = 8),
                  vp = viewport(layout.pos.row = 9, layout.pos.col = 2))
        bar.fill <- theme$bar.fill
        push.viewport(viewport(layout.pos.row = 8,
                               layout.pos.col = 4,
                               yscale = extend.limits(c(0,6)),
                               xscale = extend.limits(c(1,10))))
        grid.rect(x = c(3.5, 4.5, 5.5, 6.5, 7.5), w = rep(5,5),
                  y = c(1,2,3,4,5), h = rep(.5, ,5),
                  default.units = "native",
                  gp = gpar(fill = bar.fill$col))
        grid.rect()
        pop.viewport()
        grid.text(lab = "plot.shingle[bar.fill]",
                  ## gp = gpar(fontsize = 8),
                  vp = viewport(layout.pos.row = 9, layout.pos.col = 4))
        push.viewport(viewport(layout.pos.row = 8,
                               layout.pos.col = 6,
                               yscale = extend.limits(c(0,7)),
                               xscale = extend.limits(c(0,7))))
        grid.rect(y = c(.5, 1, 1.5, 2, 2.5, 3, 3.5), w = rep(1,7),
                  x = c(.5, 1.5, 2.5, 3.5, 4.5, 5.5, 6.5), h = 1:7,
                  default.units = "native",
                  gp = gpar(fill = bar.fill$col))
        grid.rect()
        pop.viewport()
        grid.text(lab = "histogram[bar.fill]",
                  ## gp = gpar(fontsize = 8),
                  vp = viewport(layout.pos.row = 9, layout.pos.col = 6))
        push.viewport(viewport(layout.pos.row = 8,
                               layout.pos.col = 8,
                               yscale = extend.limits(c(0,6)),
                               xscale = c(0,7)))
        grid.rect(x = rev(c(.5, 1, 1.5, 2, 2.5, 3)), h = rep(.5, 6),
                  y = c(.5, 1.5, 2.5, 3.5, 4.5, 5.5), w = 6:1,
                  default.units = "native",
                  gp = gpar(fill = bar.fill$col))
        grid.rect()
        pop.viewport()
        grid.text(lab = "barchart[bar.fill]",
                  ## gp = gpar(fontsize = 8),
                  vp = viewport(layout.pos.row = 9, layout.pos.col = 8))
        regions <- theme$regions
        len <- length(regions$col)
        push.viewport(viewport(layout.pos.row = 11,
                               layout.pos.col = 2,
                               xscale = c(0,len+1)))
        for (i in 1:len)
            grid.rect(x = i, w = 1, default.units = "native",
                      gp = gpar(col = NULL,  fill = regions$col[i]))
        grid.rect()
        pop.viewport()
        grid.text(lab = "regions",
                  ## gp = gpar(fontsize = 8),
                  vp = viewport(layout.pos.row = 12, layout.pos.col = 2))
    }    
    invisible()
}










    


### Copyright 2001-2003  Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA





prepanel.default.splom <-
    function(x, y, type, ...)
{
    list(xlim = c(0,1),
         ylim = c(0,1),
         dx = 1,
         dy = 1)
}




panel.splom <-
    function(...)
    panel.xyplot(...)





panel.pairs <-
    function(z, panel = "panel.splom", groups = NULL,
             panel.subscripts,
             subscripts,
             pscales = 5,
             panel.number = 0,  ## should always be supplied
             prepanel.limits = function(x) extend.limits(range(as.numeric(x), na.rm = TRUE)), ## factors ??
             ...)
{
    panel <- 
        if (is.function(panel)) panel 
        else if (is.character(panel)) get(panel)
        else eval(panel)

    axis.line <- trellis.par.get("axis.line")
    axis.text <- trellis.par.get("axis.text")
    n.var <- ncol(z)

    if(n.var>0) {

        lim <- list(1:n.var)
        for(i in 1:n.var) lim[[i]] <-
            if (is.list(pscales) && !is.null(pscales[[i]]$lim))
                pscales[[i]]$lim
            else prepanel.limits(z[,i])
    }
        
    ## maybe (ideally) this should be affected by scales

    draw <- is.list(pscales) || (is.numeric(pscales) && pscales!=0) # whether axes to be drawn

    splom.layout <- grid.layout(nrow=n.var, ncol=n.var)

    if (n.var > 0 && any(subscripts)) {

        push.viewport(viewport(layout=splom.layout))

        for(i in 1:n.var)
            for(j in 1:n.var)
            {
                push.viewport(viewport(layout.pos.row = n.var-i+1,
                                       layout.pos.col = j,
                                       clip = TRUE,
                                       ##gp = gpar(fontsize = fontsize.small),
                                       xscale = lim[[j]],
                                       yscale = lim[[i]]))

                if(i == j)
                {
                    if (!is.null(colnames(z)))
                        grid.text(colnames(z)[i])
                    ##gp = gpar(fontsize = 10))
                    if (draw) {
                        ## plot axes

                        if (is.factor(z[,i])) {
                            axls <- 1:nlevels(z[,i])
                            nal <- length(axls)/2+.5

                            for(tt in seq(along=axls)) {
                                if(tt <= nal) {
                                    
                                    grid.lines(y = unit(rep(axls[tt],2), "native"),
                                               x = unit(c(1,1),"npc") - unit(c(0,.25), "lines"),
                                               gp = gpar(col = axis.line$col))
                                    
                                    grid.text(label = levels(z[,i])[tt],
                                              x = unit(1,"npc") - unit(.5, "lines"),
                                              y = unit(axls[tt], "native"),
                                              just = c("right", "centre"))
                                    
                                    grid.lines(x = unit(rep(axls[tt],2), "native"),
                                               y = unit(c(0,.25), "lines"),
                                               gp = gpar(col = axis.line$col))
                                    
                                    grid.text(label = levels(z[,i])[tt],
                                              rot = 90,
                                              y = unit(0.5, "lines"),
                                              x = unit(axls[tt], "native"),
                                              just = c("left", "centre"))
                                    
                                }
                                if(tt >=nal) {
                                    
                                    grid.lines(y = unit(rep(axls[tt],2), "native"),
                                               x = unit(c(0,0.25), "lines"),
                                               gp = gpar(col = axis.line$col))
                                    
                                    grid.text(label = levels(z[,i])[tt],
                                              x = unit(0.5, "lines"),
                                              y = unit(axls[tt], "native"),
                                              just = c("left", "centre"))
                                    
                                    grid.lines(x = unit(rep(axls[tt],2), "native"),
                                               y = unit(c(1,1),"npc") - unit(c(0,.25), "lines"),
                                               gp = gpar(col = axis.line$col))
                                    
                                    grid.text(label = levels(z[,i])[tt], rot = 90,
                                              y = unit(1,"npc") - unit(.5, "lines"),
                                              x = unit(axls[tt], "native"),
                                              just = c("right", "centre"))
                                    
                                }
                                
                            }
                            
                        }
                        else {
                        
                            axls <-
                                if (is.list(pscales) && !is.null(pscales[[i]]$at))
                                    pscales[[i]]$at
                                else
                                    lpretty(lim[[i]],
                                            n = if (is.numeric(pscales))
                                            pscales else 5)

                            labels <-
                                if (is.list(pscales) && !is.null(pscales[[i]]$lab))
                                    pscales[[i]]$lab
                            ## should be rendered like factors ?
                                else
                                    as.character(axls)

                            axid <- axls>lim[[i]][1] & axls <lim[[i]][2]
                            axls <- axls[axid]
                            labels <- labels[axid]
                            nal <- length(axls)/2+.5

                            for(tt in seq(along=axls)) {
                                if(tt <= nal) {
                                    
                                    grid.lines(y = unit(rep(axls[tt],2), "native"),
                                               x = unit(c(1,1),"npc") - unit(c(0,.25), "lines"),
                                               gp = gpar(col = axis.line$col))
                                    
                                    grid.text(label = labels[tt],
                                              x = unit(1,"npc") - unit(.5, "lines"),
                                              y = unit(axls[tt], "native"),
                                              just = c("right", "centre"))
                                    
                                    grid.lines(x = unit(rep(axls[tt],2), "native"),
                                               y = unit(c(0,.25), "lines"),
                                               gp = gpar(col = axis.line$col))
                                    
                                    grid.text(label = labels[tt],
                                              y = unit(0.5, "lines"),
                                              x = unit(axls[tt], "native"),
                                              just = c("centre", "bottom"))
                                    
                                }
                                if(tt >=nal) {
                                    
                                    grid.lines(y = unit(rep(axls[tt],2), "native"),
                                               x = unit(c(0,0.25), "lines"),
                                               gp = gpar(col = axis.line$col))
                                    
                                    grid.text(label = labels[tt],
                                              x = unit(0.5, "lines"),
                                              y = unit(axls[tt], "native"),
                                              just = c("left", "centre"))
                                    
                                    grid.lines(x = unit(rep(axls[tt],2), "native"),
                                               y = unit(c(1,1),"npc") - unit(c(0,.25), "lines"),
                                               gp = gpar(col = axis.line$col))
                                    
                                    grid.text(label = labels[tt],
                                              y = unit(1,"npc") - unit(.5, "lines"),
                                              x = unit(axls[tt], "native"),
                                              just = c("centre", "top"))
                                    
                                }
                                
                            }
                        }    
                    }

                    grid.rect()

                }
                else
                {
                    pargs <-
                        if (!panel.subscripts)
                            c(list(x = as.numeric(z[subscripts, j]),
                                   y = as.numeric(z[subscripts, i]),
                                   panel.number = panel.number),
                              list(...))
                        else
                            c(list(x = as.numeric(z[subscripts, j]),
                                   y = as.numeric(z[subscripts, i]),
                                   groups = groups,
                                   subscripts = subscripts,
                                   panel.number = panel.number),
                              list(...))

                    if (!("..." %in% names(formals(panel))))
                        pargs <- pargs[names(formals(panel))]
                    do.call("panel", pargs)

                    grid.rect()
                }
                pop.viewport()
            }
        pop.viewport()
    }
}




splom <-
    function(formula,
             data = parent.frame(),
             aspect = 1,
             between = list(x = 0.5, y = 0.5),
             layout = NULL,
             panel = if (is.null(groups)) "panel.splom" else "panel.superpose",
             prepanel = NULL,
             scales = list(),
             strip = TRUE,
             groups = NULL,
             xlab = "Scatter Plot Matrix",
             xlim,
             ylab = NULL,
             ylim,
             superpanel = "panel.pairs",
             pscales = 5,
             varnames,
             ...,
             subscripts = !is.null(groups),
             subset = TRUE)
{

    ## dots <- eval(substitute(list(...)), data, parent.frame())
    dots <- list(...)

    groups <- eval(substitute(groups), data, parent.frame())
    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)

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

    ## Step 1: Evaluate x, y, etc. and do some preprocessing
    


    formname <- deparse(substitute(formula))
    formula <- eval(substitute(formula), data, parent.frame())

    form <-
        if (inherits(formula, "formula"))
            latticeParseFormula(formula, data)
        else 
            list(left = NULL,
                 right = as.data.frame(formula),
                 condition = NULL,
                 left.name = "",
                 right.name = formname)


    ##form <- latticeParseFormula(formula, data)

    cond <- form$condition


    number.of.cond <- length(cond)
    x <- as.data.frame(form$right)
    if (number.of.cond == 0) {
        strip <- FALSE
        cond <- list(as.factor(rep(1, nrow(x))))
        layout <- c(1,1,1)
        number.of.cond <- 1
    }
    if (!missing(varnames)) colnames(x) <-
        eval(substitute(varnames), data, parent.frame())

    subset <- eval(substitute(subset), data, parent.frame())
    if ("subscripts" %in% names(formals(eval(panel)))) subscripts <- TRUE
    subscr <- seq(along=x[,1])
    x <- x[subset,, drop = TRUE]
    subscr <- subscr[subset, drop = TRUE]
    

    ## create a skeleton trellis object with the
    ## less complicated components:

    foo <- do.call("trellis.skeleton",
                   c(list(aspect = aspect,
                          between = between,
                          panel = superpanel,
                          strip = strip,
                          xlab = xlab,
                          ylab = ylab), dots))

    dots <- foo$dots # arguments not processed by trellis.skeleton
    foo <- foo$foo
    foo$call <- match.call()
    foo$fontsize.normal <- 10
    foo$fontsize.small <- 8

    ## This is for cases like xlab/ylab = list(cex=2)
    if (is.list(foo$xlab) && !is.characterOrExpression(foo$xlab$label))
        foo$xlab$label <- "Scatter Plot Matrix"
    if (is.list(foo$ylab) && !is.characterOrExpression(foo$ylab$label))
        foo$ylab <- NULL

    ## Step 2: Compute scales.common (leaving out limits for now)

    ## It is not very clear exactly what effect scales is supposed
    ## to have. Not much in Trellis (probably), but there are certain
    ## components which are definitely relevant, and certail others
    ## (like log) which can be used in innovative ways. However, I'm
    ## postponing all that to later, if at all,and for now TOTALLY
    ## ignoring scales
    
    ##scales <- eval(substitute(scales), data, parent.frame())
    ##if (is.character(scales)) scales <- list(relation = scales)
    scales <- list(relation = "same", draw = FALSE)
    foo <- c(foo, 
             do.call("construct.scales", scales))


    ## Step 3: Decide if limits were specified in call:

    have.xlim <- !missing(xlim)
    if (!is.null(foo$x.scales$limit)) {
        have.xlim <- TRUE
        xlim <- foo$x.scales$limit
    }
    have.ylim <- !missing(ylim)
    if (!is.null(foo$y.scales$limit)) {
        have.ylim <- TRUE
        ylim <- foo$y.scales$limit
    }
    if (have.xlim || have.ylim) {
        warning("Limits cannot be explicitly specified")
    }
    have.xlim <- TRUE
    have.ylim <- TRUE
    xlim <- c(0,1)
    ylim <- c(0,1)
    
    ## Step 4: Decide if log scales are being used:

    have.xlog <- !is.logical(foo$x.scales$log) || foo$x.scales$log
    have.ylog <- !is.logical(foo$y.scales$log) || foo$y.scales$log
#    if (have.xlog) {
#        xlog <- foo$x.scales$log
#        xbase <-
#            if (is.logical(xlog)) 10
#            else if (is.numeric(xlog)) xlog
#            else if (xlog == "e") exp(1)
#
#        x <- log(x, xbase)
#        if (have.xlim) xlim <- log(xlim, xbase)
#    }
#    if (have.ylog) {
#        ylog <- foo$y.scales$log
#        ybase <-
#            if (is.logical(ylog)) 10
#            else if (is.numeric(ylog)) ylog
#            else if (ylog == "e") exp(1)
#
#        y <- log(y, ybase)
#        if (have.ylim) ylim <- log(ylim, ybase)
#    }
    
    ## Step 5: Process cond

    cond <- lapply(cond, as.factorOrShingle, subset, drop = TRUE)
    cond.max.level <- unlist(lapply(cond, nlevels))


    ## id.na used only to see if any plotting is needed. Not used
    ## subsequently, unlike other functions

    id.na <- FALSE
    for (j in 1:ncol(x))
        id.na <- id.na | is.na(x[,j])
    for (var in cond)
        id.na <- id.na | is.na(var)
    if (!any(!id.na)) stop("nothing to draw")
    ## Nothing simpler ?

    foo$condlevels <- lapply(cond, levels)

    ## Step 6: Evaluate layout, panel.args.common and panel.args


    foo$panel.args.common <-
        c(list(z = x,
               panel = panel,
               panel.subscripts = subscripts,
               groups = groups, # xscales = foo$x.scales, yscales = foo$y.scales,
               pscales = pscales),
          dots)

    layout <- compute.layout(layout, cond.max.level, skip = foo$skip)
    plots.per.page <- max(layout[1] * layout[2], layout[2])
    number.of.pages <- layout[3]
    foo$skip <- rep(foo$skip, length = plots.per.page)
    foo$layout <- layout
    nplots <- plots.per.page * number.of.pages

    foo$panel.args <- as.list(1:nplots)
    cond.current.level <- rep(1,number.of.cond)
    panel.number <- 1 # this is a counter for panel number
    for (page.number in 1:number.of.pages)
        if (!any(cond.max.level-cond.current.level<0))
            for (plot in 1:plots.per.page) {

                if (foo$skip[plot]) foo$panel.args[[panel.number]] <- FALSE
                else if(!any(cond.max.level-cond.current.level<0)) {

                    ##id <- !id.na
                    for(i in 1:number.of.cond)
                    {
                        var <- cond[[i]]
                        id <- if (is.shingle(var))
                            ((var >=
                              levels(var)[[cond.current.level[i]]][1])
                             & (var <=
                                levels(var)[[cond.current.level[i]]][2]))
                        else (as.numeric(var) == cond.current.level[i])
                    }

                    foo$panel.args[[panel.number]] <-
                        list(subscripts = subscr[id])

                    cond.current.level <-
                        cupdate(cond.current.level,
                                cond.max.level)
                }

                panel.number <- panel.number + 1
            }

    foo <- c(foo,
             limits.and.aspect(prepanel.default.splom,
                               prepanel = prepanel, 
                               have.xlim = have.xlim, xlim = xlim, 
                               have.ylim = have.ylim, ylim = ylim, 
                               x.relation = foo$x.scales$relation,
                               y.relation = foo$y.scales$relation,
                               panel.args.common = foo$panel.args.common,
                               panel.args = foo$panel.args,
                               aspect = aspect,
                               nplots = nplots,
                               x.axs = foo$x.scales$axs,
                               y.axs = foo$y.scales$axs))

    class(foo) <- "trellis"
    foo
}



### Copyright 2001  Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA



prepanel.default.tmd <-
    function(...)
    prepanel.default.xyplot(...)



panel.tmd <- function(...) {
    panel.abline(h=0)
    panel.xyplot(...)
}


## Fixme: log scales not handled
tmd <-
    function(object,
             aspect = "fill",
             as.table = object$as.table,
             between = list(x=object$x.between,y=object$y.between),
             key = object$key,
             layout = object$layout,
             main = object$main,
             page = object$page,
             panel = "panel.tmd",
             par.strip.text = object$par.strip.text, 
             prepanel = NULL,
             scales = list(),
             strip = object$strip,
             sub = object$sub,
             xlab = "mean",
             xlim = NULL,
             ylab = "difference",
             ylim = NULL,
             ...,
             subscripts = !is.null(groups),
             subset = TRUE)
{

    dots <- list(...)

    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)

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

    ## create a skeleton trellis object with the
    ## less complicated components:

    foo <- do.call("trellis.skeleton",
                   c(list(as.table = as.table,
                          aspect = aspect,
                          between = between,
                          key = key,
                          page = page,
                          main = main,
                          panel = panel,
                          sub = sub,
                          par.strip.text = par.strip.text,
                          strip = strip,
                          xlab = xlab,
                          ylab = ylab), dots))
                          

    dots <- foo$dots # arguments not processed by trellis.skeleton
    foo <- foo$foo
    foo$call <- match.call()
    foo$fontsize.normal <- 10
    foo$fontsize.small <- 8

    ## This is for cases like xlab/ylab = list(cex=2)
    if (is.list(foo$xlab) && !is.characterOrExpression(foo$xlab$label))
        foo$xlab$label <- form$right.name
    if (is.list(foo$ylab) && !is.characterOrExpression(foo$ylab$label))
        foo$ylab$label <- form$left.name

    ## Step 2: Compute scales.common (leaving out limits for now)

    if (is.character(scales)) scales <- list(relation = scales)
    foo <- c(foo, 
             do.call("construct.scales", scales))

    ## Step 3: Decide if limits were specified in call:

    have.xlim <- !missing(xlim)
    if (!is.null(foo$x.scales$limit)) {
        have.xlim <- TRUE
        xlim <- foo$x.scales$limit
    }
    have.ylim <- !missing(ylim)
    if (!is.null(foo$y.scales$limit)) {
        have.ylim <- TRUE
        ylim <- foo$y.scales$limit
    }

    ## Step 4: Decide if log scales are being used:

    have.xlog <- !is.logical(foo$x.scales$log) || foo$x.scales$log
    have.ylog <- !is.logical(foo$y.scales$log) || foo$y.scales$log
    if (have.xlog) { ## problem
        xlog <- foo$x.scales$log
        xbase <-
            if (is.logical(xlog)) 10
            else if (is.numeric(xlog)) xlog
            else if (xlog == "e") exp(1)

        x <- log(x, xbase)
        if (have.xlim) xlim <- log(xlim, xbase)
    }
    if (have.ylog) { ## problem
        ylog <- foo$y.scales$log
        ybase <-
            if (is.logical(ylog)) 10
            else if (is.numeric(ylog)) ylog
            else if (ylog == "e") exp(1)

        y <- log(y, ybase)
        if (have.ylim) ylim <- log(ylim, ybase)
    }
    
    ## Step 5: Process cond

    foo$condlevels <- object$condlevels

    ## Step 6: Evaluate layout, panel.args.common and panel.args

    foo$panel.args.common <- c(object$panel.args.common, dots)

    if (!missing(layout)) {
        number.of.cond <- length(foo$condlevels)
        cond.max.level <- integer(number.of.cond)
        for(i in 1:number.of.cond) {
            cond.max.level[i] <-
                if (is.character(foo$condlev[[i]])) length(foo$condlev[[i]])
                else nrow(foo$condlev[[i]])
        }
        foo$skip <- !unlist(lapply(object$panel.args , is.list))
        layout <- compute.layout(layout, cond.max.level, skip = foo$skip)
    }
    plots.per.page <- max(layout[1] * layout[2], layout[2])
    number.of.pages <- layout[3]
    foo$skip <- rep(foo$skip, length = plots.per.page)
    foo$layout <- layout
    nplots <- plots.per.page * number.of.pages

    foo$panel.args <- object$panel.args

    if ("x" %in% names(foo$panel.args.common)) {
        ## this would happen with subscripts. assuming that
        ## y would also be there then
        q < foo$panel.args.common
        x <- (q$x+q$y)/2
        y <- q$y-q$x       # will stop if any errors, not putting any more handlers
        foo$panel.args.common$x <- x
        foo$panel.args.common$y <- y
    }
    else {
        count <- 1
        for (p in foo$panel.args)
            if (is.logical(p)) # which means skip = T for this panel
                count <- count + 1 
            else {
                x <- (p$x+p$y)/2
                y <- p$y-p$x

                foo$panel.args[[count]]$x <- x
                foo$panel.args[[count]]$y <- y

                count <- count + 1
            }
    }    

    foo <- c(foo,
             limits.and.aspect(prepanel.default.tmd,
                               prepanel = prepanel, 
                               have.xlim = have.xlim, xlim = xlim, 
                               have.ylim = have.ylim, ylim = ylim, 
                               x.relation = foo$x.scales$relation,
                               y.relation = foo$y.scales$relation,
                               panel.args.common = foo$panel.args.common,
                               panel.args = foo$panel.args,
                               aspect = aspect,
                               nplots = nplots,
                               x.axs = foo$x.scales$axs,
                               y.axs = foo$y.scales$axs))

    class(foo) <- "trellis"
    foo
}



# "[.trellis" <-
#     function(x, i, layout = NULL, ...)
# {
#     x$panel.args <- x$panel.args[i]
#     if (is.list(x$x.scales$at))
#         x$x.scales$at <- x$x.scales$at[i]
#     if (is.list(x$x.scales$labels))
#         x$x.scales$labels <- x$x.scales$labels[i]
#     if (missing(layout)) layout <- c(0, length(x$panel.args), 1)
#     x$layout <- layout
#     x
# }

 




update.trellis <-
    function(object,
             aspect,
             as.table,
             between,
             key,
             layout,
             main,
             page,
             panel,
             par.strip.text,
             scales,
             skip,
             strip,
             sub,
             xlab,
             xlim,
             ylab,
             ylim,
             ...)
{
    
    if(!missing(aspect)){
        if (is.numeric(aspect)){
            object$aspect.ratio <- aspect
            object$aspect.fill <- FALSE
        }
        else if (is.character(aspect) && aspect=="fill")
            object$aspect.fill <- TRUE
        else warning("Inappropriate value of aspect")
    }
    
    if(!missing(as.table)){
        if (is.logical(as.table)) object$as.table <- as.table
        else warning("Inappropriate value of as.table")
    }
    
    if(!missing(between)){
        if ("x" %in% names(between)) object$x.between <- between$x
        if ("y" %in% names(between)) object$y.between <- between$y
    }
    
    if(!missing(key)){
        object$key <- key
    }
    
    if(!missing(layout)){
        if (length(layout)==2){
            object$layout[3] <- ceiling(object$layout[1]*object$layout[2]*object$layout[3]/
                                     max(layout[1]*layout[2], layout[2]))
            object$layout[1] <- layout[1]
            object$layout[2] <- layout[2]
        }
        else if (length(layout)==3){
            object$layout <- layout
        }
        else warning("Inappropriate value of layout")
    }



    
    if(!missing(main)){
        if (is.characterOrExpression(main))
            if (is.null(object$main)) object$main <-
                list(label = main, col = "black", cex = 1, font = 1)
            else object$main$label <- main

        else if (is.list(main)) {
            object$main[names(main)] <- main
        }
        else if (is.null(main)) object$main <- NULL
    }
    
    if(!missing(sub)){
        if (is.characterOrExpression(sub))
            if (is.null(object$sub)) object$sub <-
                list(label = sub, col = "black", cex = 1, font = 1)
            else object$sub$label <- sub

        else if (is.list(sub)) {
            object$sub[names(sub)] <- sub
        }
        else if (is.null(sub)) object$sub <- NULL
    }
    
    if(!missing(xlab)){
        if (is.characterOrExpression(xlab))
            if (is.null(object$xlab)) object$xlab <-
                list(label = xlab, col = "black", cex = 1, font = 1)
            else object$xlab$label <- xlab

        else if (is.list(xlab)) {
            object$xlab[names(xlab)] <- xlab
        }
        else if (is.null(xlab)) object$xlab <- NULL
    }
    
    if(!missing(ylab)){
        if (is.characterOrExpression(ylab))
            if (is.null(object$ylab)) object$ylab <-
                list(label = ylab, col = "black", cex = 1, font = 1)
            else object$ylab$label <- ylab

        else if (is.list(ylab)) {
            object$ylab[names(ylab)] <- ylab
        }
        else if (is.null(ylab)) object$ylab <- NULL
    }
    

    
    if(!missing(page)){
        object$page <- page
    }
    
    if(!missing(panel)){
        panel <- 
            if (is.function(panel)) panel 
            else if (is.character(panel)) get(panel)
            else eval(panel)

        if (object$fname == "splom")
            object$panel.args.common$panel <- panel
        else object$panel <- panel
    }
    
    if(!missing(par.strip.text)){
        if (is.list(par.strip.text))
            object$par.strip.text[names(par.strip.text)] <-
                par.strip.text
        else warning("par.strip.text must be a list")
    }
    
    if(!missing(skip)){
        warning("sorry, but skip cannot be changed by update")
    }
    
    if(!missing(strip)){
        if (is.logical(strip)){
            if (strip) object$strip <- strip.default
        else object$strip <- FALSE
        }
        else object$strip <- strip
    }
    
    if(!missing(xlim)){
        if (!is.list(object$x.limits)) object$x.limits <- xlim
        else warning("xlim cannot be specified unless relation = same")
    }
    
    if(!missing(ylim)){
        if (!is.list(object$y.limits)) object$y.limits <- ylim
        else warning("ylim cannot be specified unless relation = same")
    }

    if(!missing(scales)){
        
        if ("relation" %in% names(scales))
            warning("relation cannot be changed via update")
        
      

      
        if ("alternating" %in% names(scales)){
            if (is.logical(scales$alternating))
                if (scales$alternating){
                    object$x.scales$alternating <- c(1,2)
                    object$y.scales$alternating <- c(1,2)
                }
                else {
                    object$x.scales$alternating <- 1
                    object$y.scales$alternating <- 1
                }
            else if (is.numeric(scales$alternating)) {
                object$x.scales$alternating <- scales$alternating
                object$y.scales$alternating <- scales$alternating
            }
        }
        
        
        
        
        if ("x" %in% names(scales) &&
            "alternating" %in% names(scales$x)){
            if (is.logical(scales$x$alternating))
                if (scales$x$alternating){
                    object$x.scales$alternating <- c(1,2)
                }
                else {
                    object$x.scales$alternating <- 1
                }
            else if (is.numeric(scales$x$alternating)) {
                object$x.scales$alternating <- scales$x$alternating
            }
        }
        
        
        
        
        
        if ("y" %in% names(scales) &&
            "alternating" %in% names(scales$y)){
            if (is.logical(scales$y$alternating))
                if (scales$y$alternating){
                    object$y.scales$alternating <- c(1,2)
                }
                else {
                    object$y.scales$alternating <- 1
                }
            else if (is.numeric(scales$y$alternating)) {
                object$y.scales$alternating <- scales$y$alternating
            }
        }


        object$x.scales[names(scales)] <- scales
        if ("x" %in% names(scales)){
                
            object$x.scales[names(scales$x)] <- scales$x
                
            if ("relation" %in% names(scales$x))
                warning("relation cannot be changed via update")
        }
        
        object$y.scales[names(scales)] <- scales
        if ("y" %in% names(scales)){
                
            object$y.scales[names(scales$y)] <- scales$y
                
            if ("relation" %in% names(scales$y))
                warning("relation cannot be changed via update")
        }

    }

    object
}


### Copyright 2001  Deepayan Sarkar <deepayan@stat.wisc.edu>
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA




prepanel.default.xyplot <-
    function(x, y, type, subscripts, groups, ...)
{

    ## Note: shingles satisfy is.numeric()
    if (any(!is.na(x)) && any(!is.na(y))) {

        if (!missing(groups))
        {
            vals <-
                if (is.factor(groups)) levels(groups)
                else sort(unique(groups))

            dx <- numeric(0)
            dy <- numeric(0)
            for (i in seq(along=vals))
            {
                id <- (groups[subscripts] == vals[i])
                ord <- sort.list(x)
                dx <- c(dx, as.numeric(diff(x[ord])))
                dy <- c(dy, as.numeric(diff(y[ord])))
            }
        }
        else
        {
            ord <- sort.list(x)
            dx = as.numeric(diff(x[ord]))
            dy = as.numeric(diff(y[ord]))            
        }
        list(xlim = if (is.numeric(x)) range(x[is.finite(x)]) else levels(x),
             ylim = if (is.numeric(y)) range(y[is.finite(y)]) else levels(y),
             dx = dx, dy = dy)

    }
    else list(xlim = c(NA, NA),
              ylim = c(NA, NA),
              dx = NA, dy = NA)
}




panel.xyplot <-
    function(x, y, type="p",
             pch = plot.symbol$pch,
             col,
             col.line = plot.line$col,
             col.symbol = plot.symbol$col,
             lty = plot.line$lty,
             cex = plot.symbol$cex,
             lwd = plot.line$lwd, ...)
{
    x <- as.numeric(x)
    y <- as.numeric(y)
    if (length(x)>0) {


        if (!missing(col)) {
            if (missing(col.line)) col.line <- col
            if (missing(col.symbol)) col.symbol <- col
        }

        plot.symbol <- trellis.par.get("plot.symbol")
        plot.line <- trellis.par.get("plot.line")

        if ("o" %in% type || "b" %in% type)
            type <- c(type, "p", "l")


        if ("p" %in% type)
            lpoints(x = x, y = y, cex = cex,
                    col = col.symbol, pch=pch)


        if ("l" %in% type)
            llines(x=x, y=y, lty=lty, col=col.line, lwd=lwd)


        if ("h" %in% type)
            llines(x=x, y=y, type = "h", lty=lty, col=col.line, lwd=lwd)


        if ("s" %in% type) {
            ord <- sort.list(x)
            n <- length(x)
            xx <- numeric(2*n-1)
            yy <- numeric(2*n-1)

            xx[2*1:n-1] <- x[ord]
            yy[2*1:n-1] <- y[ord]
            xx[2*1:(n-1)] <- x[ord][-1]
            yy[2*1:(n-1)] <- y[ord][-n]
            llines(x=xx, y=yy,
                   lty=lty, col=col.line, lwd=lwd)
        }
        if ("S" %in% type) {
            ord <- sort.list(x)
            n <- length(x)
            xx <- numeric(2*n-1)
            yy <- numeric(2*n-1)

            xx[2*1:n-1] <- x[ord]
            yy[2*1:n-1] <- y[ord]
            xx[2*1:(n-1)] <- x[ord][-n]
            yy[2*1:(n-1)] <- y[ord][-1]
            llines(x=xx, y=yy,
                   lty=lty, col=col.line, lwd=lwd)
        }
        if ("r" %in% type) {
            panel.lmline(x, y, col = col.line, lty = lty, lwd = lwd, ...)
        }
        if ("smooth" %in% type) {
            panel.loess(x, y, col = col.line, lty = lty, lwd = lwd, ...)
        }
    }
}





xyplot <-
    function(formula,
             data = parent.frame(),
             allow.multiple = FALSE,
             outer = FALSE,
             auto.key = FALSE,
             aspect = "fill",
             layout = NULL,
             panel = if (is.null(groups)) "panel.xyplot"
             else "panel.superpose",
             prepanel = NULL,
             scales = list(),
             strip = TRUE,
             groups = NULL,
             xlab,
             xlim,
             ylab,
             ylim,
             ...,
             subscripts = !is.null(groups),
             subset = TRUE)
{

    ##dots <- eval(substitute(list(...)), data, parent.frame())
    dots <- list(...)

    groups <- eval(substitute(groups), data, parent.frame())
    subset <- eval(substitute(subset), data, parent.frame())

    ## Step 1: Evaluate x, y, etc. and do some preprocessing

    form <-
        latticeParseFormula(formula, data, subset = subset,
                            groups = groups, multiple = allow.multiple,
                            outer = outer, subscripts = TRUE)

    groups <- form$groups

    if (!is.function(panel)) panel <- eval(panel)
    if (!is.function(strip)) strip <- eval(strip)
    
    if ("subscripts" %in% names(formals(panel))) subscripts <- TRUE
    if (subscripts) subscr <- form$subscr

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

    cond <- form$condition
    number.of.cond <- length(cond)
    y <- form$left
    x <- form$right
    if (number.of.cond == 0) {
        strip <- FALSE
        cond <- list(as.factor(rep(1, length(x))))
        layout <- c(1,1,1)
        number.of.cond <- 1
    }

    if (missing(xlab)) xlab <- form$right.name
    if (missing(ylab)) ylab <- form$left.name

    ## S-Plus requires both x and y to be numeric, but we
    ## don't. Question is, should we give a warning ?

    if (!(is.numeric(x) && is.numeric(y)))
        warning("x and y are not both numeric")


    ## create a skeleton trellis object with the
    ## less complicated components:

    foo <- do.call("trellis.skeleton",
                   c(list(aspect = aspect,
                          strip = strip,
                          panel = panel,
                          xlab = xlab,
                          ylab = ylab), dots))

    dots <- foo$dots # arguments not processed by trellis.skeleton
    foo <- foo$foo
    foo$call <- match.call()
    foo$fontsize.normal <- 10
    foo$fontsize.small <- 8

    ## This is for cases like xlab/ylab = list(cex=2)
    if (is.list(foo$xlab) && !is.characterOrExpression(foo$xlab$label))
        foo$xlab$label <- form$right.name
    if (is.list(foo$ylab) && !is.characterOrExpression(foo$ylab$label))
        foo$ylab$label <- form$left.name

    ## Step 2: Compute scales.common (leaving out limits for now)

    ##scales <- eval(substitute(scales), data, parent.frame())
    if (is.character(scales)) scales <- list(relation = scales)
    foo <- c(foo, 
             do.call("construct.scales", scales))


    ## Step 3: Decide if limits were specified in call:

    have.xlim <- !missing(xlim)
    if (!is.null(foo$x.scales$limit)) {
        have.xlim <- TRUE
        xlim <- foo$x.scales$limit
    }
    have.ylim <- !missing(ylim)
    if (!is.null(foo$y.scales$limit)) {
        have.ylim <- TRUE
        ylim <- foo$y.scales$limit
    }

    ## Step 4: Decide if log scales are being used:

    have.xlog <- !is.logical(foo$x.scales$log) || foo$x.scales$log
    have.ylog <- !is.logical(foo$y.scales$log) || foo$y.scales$log
    if (have.xlog) {
        xlog <- foo$x.scales$log
        xbase <-
            if (is.logical(xlog)) 10
            else if (is.numeric(xlog)) xlog
            else if (xlog == "e") exp(1)

        x <- log(x, xbase)
        if (have.xlim) xlim <- log(xlim, xbase)
    }
    if (have.ylog) {
        ylog <- foo$y.scales$log
        ybase <-
            if (is.logical(ylog)) 10
            else if (is.numeric(ylog)) ylog
            else if (ylog == "e") exp(1)

        y <- log(y, ybase)
        if (have.ylim) ylim <- log(ylim, ybase)
    }
    
    ## Step 5: Process cond

    cond.max.level <- unlist(lapply(cond, nlevels))

    id.na <- is.na(x)|is.na(y)
    for (var in cond)
        id.na <- id.na | is.na(var)
    if (!any(!id.na)) stop("nothing to draw")
    ## Nothing simpler ?

    foo$condlevels <- lapply(cond, levels)

    ## Step 6: Evaluate layout, panel.args.common and panel.args


    foo$panel.args.common <- dots
    if (subscripts) foo$panel.args.common$groups <- groups

    layout <- compute.layout(layout, cond.max.level, skip = foo$skip)
    plots.per.page <- max(layout[1] * layout[2], layout[2])
    number.of.pages <- layout[3]
    foo$skip <- rep(foo$skip, length = plots.per.page)
    foo$layout <- layout
    nplots <- plots.per.page * number.of.pages

    foo$panel.args <- as.list(1:nplots)
    cond.current.level <- rep(1,number.of.cond)
    panel.number <- 1 # this is a counter for panel number
    for (page.number in 1:number.of.pages)
        if (!any(cond.max.level-cond.current.level<0))
            for (plot in 1:plots.per.page) {

                if (foo$skip[plot]) foo$panel.args[[panel.number]] <- FALSE
                else if(!any(cond.max.level-cond.current.level<0)) {

                    id <- !id.na
                    for(i in 1:number.of.cond)
                    {
                        var <- cond[[i]]
                        id <- id &
                        if (is.shingle(var))
                            ((var >= levels(var)[[cond.current.level[i]]][1])
                             & (var <= levels(var)[[cond.current.level[i]]][2]))
                        else (as.numeric(var) == cond.current.level[i])
                    }
                    foo$panel.args[[panel.number]] <-
                        list(x = x[id], y = y[id])
                    if (subscripts)
                        foo$panel.args[[panel.number]]$subscripts <-
                            subscr[id]

                    cond.current.level <-
                        cupdate(cond.current.level,
                                cond.max.level)
                }

                panel.number <- panel.number + 1
            }

    foo <- c(foo,
             limits.and.aspect(prepanel.default.xyplot,
                               prepanel = prepanel, 
                               have.xlim = have.xlim, xlim = xlim, 
                               have.ylim = have.ylim, ylim = ylim, 
                               x.relation = foo$x.scales$relation,
                               y.relation = foo$y.scales$relation,
                               panel.args.common = foo$panel.args.common,
                               panel.args = foo$panel.args,
                               aspect = aspect,
                               nplots = nplots,
                               x.axs = foo$x.scales$axs,
                               y.axs = foo$y.scales$axs))

    if (is.null(foo$key) && !is.null(groups) &&
        (is.list(auto.key) || (is.logical(auto.key) && auto.key)))
        foo$key <- do.call("simpleKey",
                           c(list(levels(as.factor(groups))),
                             if (is.list(auto.key)) auto.key else list()))

    class(foo) <- "trellis"
    foo
}









### Copyright 2000-2003 Deepayan Sarkar <deepayan@stat.wisc.edu>,
###
### This file is part of the lattice library 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA



.onLoad <- function(lib, pkg) {
  library.dynam(pkg, pkg, lib )
  #import(grid) # will this do ?  apparently not
  ## do we want grid functions visible
  ##if (!require(grid))
  ##    stop("lattice requires grid, but grid couldn't be loaded")
}

.LatticeEnv <- new.env()

## Need global variable to handle more in print.trellis
assign(".lattice.print.more", FALSE, env = .LatticeEnv)
assign("lattice.theme", list(), env = .LatticeEnv)

.noGenerics <- TRUE

.onUnload <- function(libpath)
    library.dynam.unload("lattice", libpath)









# old (pre NAMESPACE version)
#.First.lib <- function(lib, pkg) {
#  library.dynam(pkg, pkg, lib )
#  if (!require(grid))
#      stop("lattice requires grid, but grid couldn't be loaded")
#}

## Need global variable to handle more in print.trellis
#.lattice.print.more <- FALSE



