R/combineLimits.R

In latticeExtra: Extra Graphical Utilities Based on Lattice

## also available in lattice, but not exported
is.characterOrExpression <- function (x) is.character(x) || is.expression(x)

.arrayIndices <- function(d, i)
    ## Suppose we have an array 'x' with dimension 'd'.  We can index
    ## 'x' in two different ways: x[i] or x[i_1, i_2, ..., i_d].
    ## Here, we are given 'i', and want to compute i_1, i_2, ..., i_d.
{
    ## Here's what we are doing:
    ## For length(d) == 3, note that (for 0-based indexing)
    ## 
    ## i1 = (i mod d[1])
    ## i2 = (i mod d[1] * d[2]) div d[1]
    ## i3 = (i mod d[1] * d[2] * d[3]) div d[1] * d[2]
    n <- length(d)
    ans <- vector(mode = "list", length = n)
    for (k in seq_along(ans))
    {
        ans[[k]] <- 1L + (((i-1L) %% prod(head(d, k)))
                          %/%
                          prod(head(d, k-1L)))
    }
    ans
}


combineLimits <-
    function(x, margin.x = 2L, margin.y = 1L,
             extend = TRUE, adjust.labels = TRUE)
{
    if (length(dim(x)) == 1L)
        warning("Only one conditioning variable; nothing interesting will happen.")
    indices <- .arrayIndices(dim(x), seq_len(prod(dim(x))))
    ## For regular `numeric' scales, all we need is to modify
    ## $[xy].scales.  But for `factor' scales, we need to leave
    ## $[xy].scales alone, and instead modify $[xy].used.at and $[xy].num.limit
    modifyLimits <- function(limits, margin, ext)
    {
        limits <- array(limits, dim = dim(x))
        for (i in seq_len(prod(dim(x))))
        {
            ## index.combine <- index.entry <- Rows(indices, i)
            index.combine <- Rows(indices, i)
            index.combine[margin] <- list(TRUE)
            ## limits[[i]] <-
            ##     range(do.call("[", c(list(limits), index.combine)), finite = TRUE)
            
            li <- unlist(do.call("[", c(list(limits), index.combine)))
            limits[[i]] <- if(all(is.na(li))) li else range(li, finite = TRUE)
        }
        if (ext) lapply(limits, lattice:::extend.limits)
        else limits
    }
    modifyUsed <- function(used.at, margin)
    {
        used.at <- array(used.at, dim = dim(x))
        for (i in seq_len(prod(dim(x))))
        {
            index.combine <- Rows(indices, i)
            index.combine[margin] <- list(TRUE)
            li <- unlist(do.call("[", c(list(used.at), index.combine)))
            used.at[[i]] <- sort(unique(li))
        }
        used.at
    }
    if (x$x.scales$relation != "free" && x$y.scales$relation != "free")
        warning("Function only has effect for scales with 'relation=\"free\"'.")
    if (x$x.scales$relation == "free" && length(margin.x))
    {
        if (is.characterOrExpression(x$x.limits[[1]]))
        {
            x$x.used.at <- modifyUsed(x$x.used.at, margin.x)
            x$x.num.limit <- modifyLimits(x$x.num.limit, margin.x, ext = FALSE)
        }
        else
            x$x.limits <- modifyLimits(x$x.limits, margin.x, ext = extend)
    }
    if (x$y.scales$relation == "free" && length(margin.y))
    {
        if (is.characterOrExpression(x$y.limits[[1]]))
        {
            x$y.used.at <- modifyUsed(x$y.used.at, margin.y)
            x$y.num.limit <- modifyLimits(x$y.num.limit, margin.y, ext = FALSE)
        }
        else
            x$y.limits <- modifyLimits(x$y.limits, margin.y, ext = extend)
    }
    if (adjust.labels)
    {
        ## Drop all but left/bottom-most labels, and set space to 0
        ## for those.  Needs to know layout, and will set it unless
        ## already set.
        npackets <- prod(dim(x))
        par.settings <- if (is.null(x$par.settings)) list() else x$par.settings
        if (is.null(x$layout))
            x$layout <-
                if (length(dim(x)) == 1L) c(dim(x), 1)
                else dim(x)[1:2]
        else if (!isTRUE(all.equal(x$layout[1:2], dim(x)[1:2])))
        {
            warning("'layout' does not match dimensions; displayed scales may be wrong.")
        }
        if (any(is.na(x$layout) | x$layout == 0))
            stop("'layout' must explicitly determine number of rows and columns")
        if (x$x.scales$relation == "free" && length(margin.x))
        {
            ## change x-scales
            if (is.list(x$x.scales$at))
            {
                warning("Explicit per-panel tick mark locations ignored")
                x$x.scales$at <- FALSE
            }
            page.at <- 
                if (x$as.table)
                    rep(list(NULL, x$x.scales$at),
                        c(x$layout[1] * (x$layout[2]-1), x$layout[1]))
                else
                    rep(list(x$x.scales$at, NULL),
                        c(x$layout[1], x$layout[1] * (x$layout[2]-1)))
            x$x.scales$at <- rep(page.at, length.out = npackets)
            par.settings <-
                if (x$as.table)
                    modifyList(par.settings,
                               list(layout.heights =
                                    list(axis.panel = rep(c(0, 1), c(x$layout[2]-1, 1)))))
                else 
                    modifyList(par.settings,
                               list(layout.heights =
                                    list(axis.panel = rep(c(1, 0), c(1, x$layout[2]-1)))))
        }
        if (x$y.scales$relation == "free" && length(margin.y))
        {
            ## change y-scales
            if (is.list(x$y.scales$at))
            {
                warning("Explicit per-panel tick mark locations ignored")
                x$y.scales$at <- FALSE
            }
            page.at <- rep(list(TRUE, NULL), c(1, x$layout[1]-1))
            x$y.scales$at <- rep(page.at, length.out = npackets)
            par.settings <-
                modifyList(par.settings,
                           list(layout.widths =
                                list(axis.panel = rep(c(1, 0), c(1, x$layout[1]-1)))))
        }
        x$par.settings <- par.settings
    }
    x
}