The R Project SVN R-packages

### Copyright (C) 2001-2006  Deepayan Sarkar <Deepayan.Sarkar@R-project.org>
###
### This file is part of the lattice package for R.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
###
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
###
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
### MA 02110-1301, USA




construct.scales <-
    function(draw = TRUE,
             axs = "r",
             tck = 1,
             tick.number = 5,
             lty = FALSE, lwd = FALSE,
             cex = FALSE,
             rot = FALSE,
             at = FALSE,
             labels = FALSE,
             col = FALSE,
             col.line = col,
             alpha = FALSE,
             alpha.line = alpha,
             log = FALSE,
             font = FALSE,
             fontfamily = FALSE,
             fontface = FALSE,
             alternating = TRUE,
             relation = "same",
             abbreviate = FALSE,
             minlength = 4,
             limits = NULL,
             format = NULL,
             x = NULL,
             y = NULL,
             ...)   ## FIXME: how to handle ...
{
    xfoo <- list(draw = draw, axs = axs, tck = tck,
                 tick.number = tick.number,
                 lty = lty, lwd = lwd,
                 cex = cex,
                 rot = rot,
                 font = font,
                 fontfamily = fontfamily, fontface = fontface, 
                 at = at, labels = labels,
                 col = col, col.line = col.line,
                 alpha = alpha, alpha.line = alpha.line,
                 log = log,
                 alternating = alternating,
                 relation = relation,
                 abbreviate = abbreviate,
                 minlength = minlength,
                 limits = limits,
                 format = format)
    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.out = 2)
        yfoo[[nm]] <- rep(yfoo[[nm]], length.out = 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 = FALSE, lwd = FALSE,
             distance = c(1,1,1),
             tick.number = 5,
             cex = FALSE,
             rot = FALSE,
             at = FALSE,
             labels = FALSE,
             col = FALSE,
             col.line = col,
             alpha = FALSE,
             alpha.line = col,
             log = FALSE,
             font = FALSE,
             fontfamily = FALSE,
             fontface = FALSE,
             arrows = TRUE,
             relation = "same",
             format = NULL,
             abbreviate = FALSE,
             minlength = 4,
             x = NULL,
             y = NULL,
             z = NULL,
             ...)
{
    xfoo <- list(draw = draw, axs = axs, tck = tck,
                 lty = lty, lwd = lwd,
                 tick.number = tick.number,
                 cex = cex, rot = rot, font = font,
                 fontfamily = fontfamily, fontface = fontface, 
                 at = at, labels = labels,
                 col = col, col.line = col.line,
                 alpha = alpha, alpha.line = alpha.line,
                 log = log, arrows = arrows,
                 relation = relation, format = format,
                 abbreviate = abbreviate, minlength = minlength)
    yfoo <- xfoo
    zfoo <- xfoo
    distance <- rep(distance, length.out = 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)
}





## FIXME: the following function uses a very unstructured patchwork of
## logic.  Need to change it to use some sort of method dispatch to
## work with different types of limits (dates, factors, etc)



limitsFromLimitlist <-
    function(have.lim,
             lim,
             relation,
             limitlist,
             used.at,
             numlimitlist,
             axs,
             npackets)
    ## have.lim: logical, whether xlim/ylim was explicitly specified
    ## lim: the specified limit if have.lim = TRUE
    ## relation: same/free/sliced
    ## limitlist: list of limits from prepanel calculations, one for each panel
    ## numlimitlist: (optional) numeric locations for factors (lim
    ##                will be levels including unused ones)
    ## axs: "r", "i" etc, passed on to extend.limits

    ## return value depends on relation. (See limits.and.aspect below,
    ## where this is used, for partial enlightenment.)
{

    if (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

        ## Additional complication: Need to preserve class of limits,
        ## to be used later in tick location/label calculation. Not a
        ## problem in other cases, but here unlist-ing loses the
        ## class.


        if (have.lim)
        {
            if (is.list(lim))
                stop("limits cannot be a list when relation = same")
            limits <- lim
            slicelen <-
                ## this no longer works for dates (R 2.6)
##                 if (is.numeric(lim)) diff(range(lim))
##                 else length(lim) + 2
                if (is.character(lim)) length(lim) + 2
                else diff(range(as.numeric(lim)))
        }
        else
        {
            ## should check that all classes are the same. How ? What
            ## about NA's ? Arrgh!

            ## to handle NA's, how about:

            all.na <- unlist(lapply(limitlist, function(x) all(is.na(x))))
            class.lim <- ## retain non-NA limitlists only
                lapply(limitlist[!all.na], class)
            ## class.lim is a list now, may be length 0
            limits <- unlist(limitlist) ## loses the class attribute

            ## if (length(limits) > 0)
            if (sum(!is.na(limits)) > 0)
            {
                if (is.character(limits))
                {
                    limits <- unique(limits[!is.na(limits)])
                    slicelen <- diff(extend.limits(limits, axs = axs))
                }
                else ## if (is.numeric(limits)) # or dates etc
                {
                    limits <-
                        extend.limits(range(as.numeric(limits), finite = TRUE),
                                      axs = axs)
                    slicelen <- diff(range(limits, finite = TRUE))
                }

                ## hopefully put back appropriate class of limits:
                ## FIXME: date changes may have messed this up

                if (length(class.lim) > 0)
                    class(limits) <-
                        if (all(class.lim[[1]] == "integer"))
                            "numeric" else class.lim[[1]]

                ## (have to handle "integer" specially, since variable
                ## specifications like 1:10 are rather common, and
                ## class() <- "integer" would turn the limits into
                ## integers)
            }
            else
            {
                limits <- c(0,1)
                slicelen <- 1
            }
        }
        ans <- list(limits = limits, slicelen = slicelen)
    }
    else if (relation == "sliced")
    {
        if (have.lim)
        {
            if (is.list(lim))
            {
                limits <- rep(lim, length.out = npackets)
            }
            else warning("Explicitly specified limits ignored")
        }
        slicelen <- limitlist
        for (i in seq_along(limitlist))
        {
            slicelen[[i]] <-
                ## if (is.numeric(limitlist[[i]]))
                if (!is.character(limitlist[[i]]))
                {
                    if (any(is.finite(limitlist[[i]])))
                        ## range unnecessary, but...
                        diff(range(as.numeric(limitlist[[i]]), finite = TRUE))
                    else NA_real_
                }
                else if (!any(is.na(numlimitlist[[i]])))
                    diff(range(as.numeric(numlimitlist[[i]])))
                else NA_real_
        }
        slicelen <-
            (if (axs == "i") 1 else 1 + 2 * lattice.getOption("axis.padding")$numeric) *
                max(unlist(slicelen), na.rm = TRUE)
        for (i in seq_along(limitlist))
        {
            if (is.numeric(limitlist[[i]]))
                limitlist[[i]] <-
                    extend.limits(limitlist[[i]], length = slicelen)
        }
        for (i in seq_along(numlimitlist))
        {
            if (!all(is.na(numlimitlist[[i]])))
                numlimitlist[[i]] <-
                    extend.limits(as.numeric(numlimitlist[[i]]), length = slicelen)
        }
        ans <-
            list(limits = limitlist,
                 used.at = used.at,
                 numlimitlist = numlimitlist,
                 slicelen = slicelen)
    }
    else if (relation == "free")
    {
        if (have.lim)
        {
            ## This is the only situation where limits can be a list
            ## (doesn't make sense when relation="same", ignored when
            ## relation="sliced").  Even if limits is not a list (but
            ## is specified), it will be treated as a list, and
            ## repeated as necessary (see further comments below).

            if (!is.list(lim)) lim <- list(lim)

            ## There's a subtle consideration here.  It is possible
            ## for some panels to have nothing in them (or only NA's).
            ## Such panels usually have their prepanel functions
            ## return NA.  When 'limits' is specified as a list, this
            ## will be interpreted as the limit specification for the
            ## non-empty panels only (this is an arbitrary choice, but
            ## it usually makes more sense, even though it's less
            ## general than the other choice).

            ## which ones are non-NA?
            id <- which(sapply(limitlist, function(x) !all(is.na(x))))

            ## replace these with the limits supplied, except if the
            ## supplied limits are NULL, in which case retain limits
            ## calculated by prepanel.

            old.limitlist <- limitlist
            limitlist[id] <- lim
            which.null <- sapply(limitlist, is.null)
            limitlist[which.null] <- old.limitlist[which.null]
        }
        for (i in seq_along(limitlist))
        {
            if (!all(is.na(limitlist[[i]])) && !is.character(limitlist[[i]])) 
                limitlist[[i]] <- ## preserves class
                    extend.limits(limitlist[[i]], axs = axs)
            ## o.w., keep it as it is
        }
        slicelen <- numeric(length(limitlist))
        for (i in seq_along(limitlist))
            slicelen[i] <-
                if (!is.character(limitlist[[i]]))
                    diff(range(as.numeric(limitlist[[i]])))
                else if (!any(is.na(numlimitlist[[i]])))
                    diff(range(numlimitlist[[i]]))
                else NA_real_
        ans <-
            list(limits = limitlist,
                 used.at = used.at,
                 numlimitlist = numlimitlist,
                 slicelen = slicelen)
    }
    ans
}




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,
             banking = lattice.getOption("banking"),
             npackets = length(panel.args),
             x.axs = "r", y.axs = "r",
             ...)  ## extra arguments for prepanel (for qqmathline)
{
    if (npackets<1) stop("need at least one panel")
    x.limits <- vector("list", npackets)
    y.limits <- vector("list", npackets)
    x.used.at <- vector("list", npackets)
    y.used.at <- vector("list", npackets)
    x.num.limit <- vector("list", npackets)
    y.num.limit <- vector("list", npackets)
    dxdy <- vector("list", npackets)

    for (count in seq_len(npackets))
    {
        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)) ## results will 'overwrite' defaults
            {
                prenames <- names(formals(prepanel))
                if (!("..." %in% prenames)) pargs <- pargs[intersect(names(pargs), prenames)]
                pretem <- do.call("prepanel", pargs)
                tem <- updateList(tem, pretem)
                ## tem[names(pretem)] <- pretem
            }
            x.limits[[count]] <- tem$xlim
            y.limits[[count]] <- tem$ylim
            x.used.at[[count]] <- if (is.null(tem$xat)) NA else tem$xat
            y.used.at[[count]] <- if (is.null(tem$yat)) NA else tem$yat
            x.num.limit[[count]] <- if (is.null(tem$xat)) NA else range(tem$xat)
            y.num.limit[[count]] <- if (is.null(tem$yat)) NA else range(tem$yat)
            dxdy[[count]] <- list(dx = tem$dx, dy = tem$dy)
        }
        else  ## this happens for empty panels
        {
            x.limits[[count]] <- c(NA_real_, NA_real_)
            y.limits[[count]] <- c(NA_real_, NA_real_)
            x.used.at[[count]] <- NA_real_
            y.used.at[[count]] <- NA_real_
            x.num.limit[[count]] <- NA_real_
            y.num.limit[[count]] <- NA_real_
            dxdy[[count]] <- list(dx = NA_real_, dy = NA_real_)
        }
    }

    ## 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, shingle or POSIXt etc), 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.

    x.limits <-
        limitsFromLimitlist(have.lim = have.xlim,
                            lim = xlim,
                            relation = x.relation,
                            limitlist = x.limits,
                            used.at = x.used.at,
                            numlimitlist = x.num.limit,
                            axs = x.axs,
                            npackets = npackets)
    y.limits <-
        limitsFromLimitlist(have.lim = have.ylim,
                            lim = ylim,
                            relation = y.relation,
                            limitlist = y.limits,
                            used.at = y.used.at,
                            numlimitlist = y.num.limit,
                            axs = y.axs,
                            npackets = npackets)

    if (is.character(aspect))
    {
        if (aspect == "xy")
        {
            aspect <-
                median(sapply(dxdy, banking) *
                       y.limits$slicelen /
                       x.limits$slicelen, 
                       na.rm = TRUE)
### old aspect calculation
##             aspect <- median(unlist(lapply(dxdy, banking)),
##                              na.rm = TRUE) * y.limits$slicelen /
##                                  x.limits$slicelen
##             if (y.relation == "free" || x.relation == "free")
##                 warning("'aspect=xy' when 'relation=free' is not sensible")
        }
        else if (aspect == "iso")
        {
            aspect <-
                median(y.limits$slicelen / x.limits$slicelen,
                       na.rm = TRUE)
            if (y.relation == "free" || x.relation == "free")
                warning("'aspect=\"iso\"' approximate since 'relation=\"free\"'")
        }
        else aspect <- 1
    }
    list(x.limits = x.limits$limits,
         y.limits = y.limits$limits,
         x.used.at = x.limits$used.at,
         y.used.at = y.limits$used.at,
         x.num.limit = x.limits$numlimitlist,
         y.num.limit = y.limits$numlimitlist,
         aspect.ratio = aspect,
         prepanel.default = prepanel.default.function,
         prepanel = prepanel)
}