# SCM Repository

[latticeextra] View of /pkg/R/combineLimits.R
 [latticeextra] / pkg / R / combineLimits.R

# View of /pkg/R/combineLimits.R

Fri Nov 25 05:25:06 2011 UTC (11 years, 2 months ago) by deepayan
File size: 5890 byte(s)
`improved combineLimits() to support 'factor' scales`
```## 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)))
%/%
}
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)
}
{
## Drop all but left/bottom-most labels, and set space to 0
## for those.  Needs to know layout, and will set it unless
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
}

```