SCM Repository
[latticeextra] / pkg / R / combineLimits.R |
View of /pkg/R/combineLimits.R
Parent Directory
|
Revision Log
Revision 182 -
(download)
(annotate)
Fri Nov 25 05:25:06 2011 UTC (11 years, 2 months ago) by deepayan
File size: 5890 byte(s)
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))) %/% 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 }
root@r-forge.r-project.org | ViewVC Help |
Powered by ViewVC 1.0.0 |