The R Project SVN
R-packages
(root)/trunk/lattice/R/common.R – Rev 5339
Rev 5315 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
### Copyright (C) 2001-2006 Deepayan Sarkar <Deepayan.Sarkar@R-project.org>### Copyright (C) 2001-2005 Saikat DebRoy <saikat@stat.wisc.edu>###### 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, USAprepanel.null <- function() {list(xlim = rep(NA_real_, 2),ylim = rep(NA_real_, 2),dx = NA_real_,dy = NA_real_)}cupdate <- function(index, maxim){## This unexported 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.if(length(index)!=length(maxim)||length(maxim)<=0)stop("Inappropriate arguments")index[1] <- index[1] + 1if (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]# }## a function similar to (but with much less bells and whistles than)## interaction, with exactly 2 factors, and levels ordered like that## in f:g (the point is to have a 'sep' argument). Solely intended## for use below in latticeParseFormulainteraction2 <-function (f, g, sep = ":"){ans <- f:glevels(ans) <-as.vector(t(outer(levels(f), levels(g),paste, sep = sep)))ans}latticeParseFormula <-function(model, data, dimension = 2, subset = TRUE,groups = NULL, multiple = FALSE, outer = FALSE,subscripts = FALSE, drop = NULL)## this function mostly written by Saikat{## local function to get length 1 name from expressions (deparse## can split long expressions into several pieces), typically for## subsequent use as labels. Could be either of the following:expr2char <- function(x) paste(deparse(x), collapse = "")## expr2char <- function(x) deparse(x)[1]## by this time, groups is usually already evaluated. To make## things slightly more convenient, we will now also allow groups## to be of the form groups = ~g, in which case g will be## evaluated nowif (inherits(groups, "formula")){groupVar <- as.character(groups)[2]groups <- eval(parse(text = groupVar), data, environment(groups))}if (is.null(drop)) drop <- TRUEif (is.list(drop)){drop.unused.cond <- if (is.null(drop$cond)) TRUE else drop$conddrop.unused.data <- if (is.null(drop$data)) TRUE else drop$data}else{drop.unused.cond <- dropdrop.unused.data <- drop}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){## WAS: model <- eval(parse(text = paste("~", deparse(model))))[[2]]## but that's not good (PR#7395)model <- substitute(~m, list(m = 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.attrx}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)){## ignore multiple = TRUEmultiple <- FALSEwarning("'multiple=TRUE' ignored ('groups' non-null with '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(gettextf("invalid dimension '%s'", as.character(dimension)))if (length(model) == 3) { ## <something> ~ <something>if (multiple) {varsLHS <- parseSide(model[[2]])nLHS <- length(varsLHS)} else {varsLHS <- list(model[[2]])nLHS <- 1}} else { ## ~ <something>nLHS <- 1}modelRHS <- model[[length(model)]]if (length(modelRHS) == 3 && modelRHS[[1]] == as.name("|"))modelRHS <- modelRHS[[2]]## Note that when dimension = 3, multiple does not apply to RHSenv <- 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, expr2char)for (i in seq_along(modelRHS.vars)) {ans$condition[[i]] <-lrep(as.factorOrShingle(eval(modelRHS.vars[[i]], data, env),subset, drop = drop.unused.cond), nLHS * nRHS)}} else if (multiple && dimension == 2) {varsRHS <- parseSide(modelRHS)nRHS <- length(varsRHS)} else {varsRHS <- list(modelRHS)nRHS <- 1}if (length(model) == 3){## Note: special case if tmp is a matrix. This probably means## we are dealing with the parametric 3-D surface rendering## option in wireframe. subset will be ignored in that case.## allow.multiple must be effectively FALSE in that caseans$left.name <- expr2char(model[[2]])ans$left <-lrep(concat(lapply(varsLHS,function(i) {tmp <- eval(i, data, env)if (!is.matrix(tmp))tmp <-if (is.factor(tmp) || is.shingle(tmp))tmp[subset, drop = drop.unused.data]elsetmp[subset]if (inherits(tmp, "POSIXt"))tmp <- as.POSIXct(tmp)tmp})), nRHS)}if (dimension == 2){## this part belongs in the first if block, but we need nobs## later in either case, so keeping it here.tmp <- eval(varsRHS[[1]], data, env)if (is.matrix(tmp)) tmp <- as.data.frame(tmp)### This was a attempted new feature that turned out not to be such a### good idea. It would change '~x | a' to 'rownames(data) ~ x | a',### which is good for dot plot, but not good for bwplot. So, back to### old behaviour...## else if (length(model) == 2 && is.data.frame(data) &&## (is.vector(tmp, "numeric") || is.factor(tmp)) &&## is.null(names(tmp)))## {## names(tmp) <- rownames(data) # for dotplot(~x, data)## }nobs <- if (is.data.frame(tmp)) nrow(tmp) else length(tmp)if (nLHS == 1 && nRHS == 1) {if (is.data.frame(tmp))ans$right <- tmp[subset, ] ## doesn't do the drop=TRUE thing for factors/shingleselseans$right <-if (is.factor(tmp) || is.shingle(tmp))tmp[subset, drop = drop.unused.data]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 = drop.unused.data]elsetmp[subset]tmp <-lrep(tmp, nLHS)if (inherits(tmp, "POSIXt"))tmp <- as.POSIXct(tmp)tmp}))}ans$right.name <- expr2char(modelRHS)nRows <- length(ans$right)/(nLHS * nRHS)}else if (dimension == 3 && length(modelRHS) == 3 &&(modelRHS[[1]] == "*" || modelRHS[[1]] == "+")){## Note that when dimension = 3, multiple does not apply to## RHS, but nLHS may be > 1## Note: special case if tmp is a matrix. This probably means## we are dealing with the parametric 3-D surface rendering## option in wireframe. subset will be ignored in that case## allow.multiple must be effectively FALSE in that casetmp <- eval(modelRHS[[2]], data, env)nobs <- length(tmp)if (!is.matrix(tmp)) ## see note abovetmp <-if (is.factor(tmp) || is.shingle(tmp))tmp[subset, drop = drop.unused.data]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)if (!is.matrix(tmp)) ## see note abovetmp <-if (is.factor(tmp) || is.shingle(tmp))tmp[subset, drop = drop.unused.data]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 <- expr2char(modelRHS[[2]])ans$right.y.name <- expr2char(modelRHS[[3]])nRows <- length(ans$right.x)/nLHS}else stop("invalid model")if (nLHS > 1)LHSgroups <-rep(gl(nLHS, nRows,labels = sapply(varsLHS, expr2char)),nRHS)if (nRHS > 1)RHSgroups <-gl(nRHS, nRows*nLHS, labels = sapply(varsRHS, expr2char))newFactor <-if (nLHS > 1 && nRHS > 1) {interaction2(LHSgroups, RHSgroups, sep = lattice.getOption("interaction.sep"))## WAS: factor(paste(LHSgroups, RHSgroups, sep=" * "))} else if (nLHS > 1)LHSgroupselse if (nRHS > 1)RHSgroupselse NULLif (nLHS == 1 && nRHS == 1) {## subscripts is supposed to provide indices to rows in the## original data frame. When both nLHS and nRHS are 1, this is## simple --- it's seq(length = length of variables)[subset]## (note that groups is never subsetted, so groups[subscripts]## matches subsetted data, indeed, that's how 'groups' is used## in panel functions.if (!is.null(groups)) ans$groups <- groupsif (subscripts) ans$subscr <- seq_len(nobs)[subset]}else 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)elseans$condition[[length(ans$condition) + 1]] <- newFactor}else stop("newFactor cannot be NULL; you have found a bug!")## note that groups[subscripts] must match rest of (subsetted)## data. This matters when groups is non-null and is repeated## nLHS * nRHS times. It doesn't matter otherwise, but doing## it this way doesn't cause any trouble either. So there.if (subscripts)ans$subscr <-as.vector(matrix(seq_len(nobs * nLHS * nRHS), nrow = nobs)[subset, ])}else { ## that is, nLHS * nRHS > 1, outer = FALSEif (is.null(groups) && !is.null(newFactor))ans$groups <- newFactorelse stop("newFactor != NULL && groups == NULL does not hold; you have found a bug!")## In this case, groups is something generated artificially,## and is always exactly as long as the rest of the subsetted## variables. So subscr has to be a simple seq, as long as the## new groups.if (subscripts) ans$subscr <- seq_len(length(newFactor))## checkif (length(newFactor) != nRows * nLHS * nRHS)stop("Length check mismatch; you have found a bug!")}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}## method in Visualizing Data: needs x-range and y-range as well. Not## sure what the best way to extend the API is; for now, we will just## define (but not export) an implementationweighted.banking <-function(dx, dy = 1, xrange = sum(dx), yrange = sum(dy)){if (is.list(dx)) {if (is.null(names(dx))) names(dx) <- c("dx", "dy")dy <- abs(dx[["dy"]])dx <- abs(dx[["dx"]])}if (length(dx)!=length(dy)) stop("Non matching lengths")id <- dx!=0 & dy!=0 & !is.na(dx) & !is.na(dy)if (any(id)){ndx <- dx / xrangendy <- dy / yrangeobj <- function(a){sum(atan(a * ndy / ndx) * sqrt(ndx^2 + a^2 * ndy^2) ) /sum(sqrt(ndx^2 + a^2 * ndy^2)) -base::pi / 4}## r <- abs(dx[id]/dy[id])## median(r)## transform to have arg between 0 and 1objtan <- function(x) obj(tan(base::pi * x / 2))u <- uniroot(f = objtan, lower = 0.01, upper = 0.99)aspect.ratio <- tan(base::pi * u$root / 2)aspect.ratio * xrange / yrange}else 1}extend.limits <-function(lim, length = 1, axs = "r",prop =if (axs == "i") 0else lattice.getOption("axis.padding")$numeric){## if (!is.numeric(lim)) NAif (all(is.na(lim))) NA_real_ # or lim?else if (is.character(lim) ){c(1, length(lim)) + c(-1, 1) * if (axs == "i") 0.5 else lattice.getOption("axis.padding")$factor}else if (length(lim) == 2){if (lim[1] > lim[2]){ccall <- match.call()ccall$lim <- rev(lim)ans <- eval.parent(ccall)return (rev(ans))}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'")}}### this is a catch-common-arguments function that intercepts several### common arguments. These are currently documented in ?xyplot,### under \dots (...). Some arguments of trellis.skeleton are also### formal arguments to xyplot, and are documented as such. These are### indicated below with a comment. This is useful to keep track of### documented arguments, because the formal codoc system doesn't work### here (trellis.skeleton is not exported and hence not formally### documented).### one special exception is 'subscripts'. A 'subscripts' argument is### required in the panel functions for panel.identify etc to work### properly. However, not all high level functions always pass a### suitable 'subscripts' argument to its panel function (but some,### like 'splom' and 'levelplot' do). For those that do not, a### 'subscripts=TRUE' argument can change the behaviour. The others### don't have a 'subscripts' argument (as it is redundant), but we'll### capture and ignore it here to keep the interface consistent.trellis.skeleton <-function(formula = NULL,cond,aspect = default.args$aspect, # argument in xyplotas.table = default.args$as.table,between = default.args$between,key = NULL,legend = NULL,page = default.args$page,main = default.args$main,sub = default.args$sub,par.strip.text = default.args$par.strip.text,layout = default.args$layout,skip = default.args$skip,strip = default.args$strip.default, # argument in xyplotstrip.left = FALSE,xlab.default = NULL,ylab.default = NULL,xlab = NULL, # argument in xyplotylab = NULL, # argument in xyplotpanel, # argument in xyplotxscale.components = default.args$xscale.components,yscale.components = default.args$yscale.components,axis = default.args$axis,subscripts = TRUE, # ignored, for reasons given aboveindex.cond = NULL,perm.cond = NULL,...,par.settings = NULL,plot.args = NULL,lattice.options = NULL){default.args <- lattice.getOption("default.args")if (is.null(skip)) skip <- FALSEfoo <-list(formula = formula,as.table = as.table,aspect.fill = (aspect == "fill"),## key = key,legend = construct.legend(legend = legend, key = key),panel = panel,page = page,layout = layout,skip = skip,strip = if (is.logical(strip) && strip) "strip.default"else strip,strip.left = if (is.logical(strip.left) && strip.left) strip.custom(horizontal = FALSE)else strip.left,xscale.components = xscale.components,yscale.components = yscale.components,axis = axis,xlab = xlab,ylab = ylab,xlab.default = xlab.default,ylab.default = ylab.default,main = main,sub = sub,x.between = 0,y.between = 0,par.settings = par.settings,plot.args = plot.args,lattice.options = lattice.options,par.strip.text = par.strip.text,index.cond = index.cond,perm.cond = perm.cond)if (!is.null(between$x)) foo$x.between <- between$xif (!is.null(between$y)) foo$y.between <- between$yfoo$condlevels <- lapply(cond, levels)list(foo = foo, dots = list(...))}cond.orders <- function(foo, ...)## function to determine order of panels within a cond. variable## foo: trellis object-to-be## calculate actual values for index.cond and perm.cond.## index.cond can be a function, in which case it would be used to## determing order of levels within conditioning variables## Question: should these be determined at run-time? Wouldn't be## impossible, but has the disadvantage that looking at the## trellis object will be totally uninformative in the default## case (when both would be NULL). In a sense, this is fine, since## having index.cond be a function is similar to having a prepanel## function. After all, the results depend only on the panel## contents, and those cannot be changed via update.{## the following to be used for changing order of conditioning## variables and indexing their levels. The object foo already has## components index.cond and perm.cond as whatever was passed to## the original function call. If these are NULL, suitable## defaults need to be computed. If foo$index.cond is a function,## index.cond has to be computed appropriately.index.cond <-vector(mode = "list",length = length(foo$condlevels))for (i in seq_along(foo$condlevels))index.cond[[i]] <- seq_along(foo$condlevels[[i]])perm.cond <- seq_len(length(foo$condlevels))if (!is.null(foo$perm.cond)){if (all(sort(foo$perm.cond) == perm.cond))perm.cond <- foo$perm.condelse stop("Invalid value of perm.cond")}if (!is.null(foo$index.cond)){if (is.list(foo$index.cond) && length(foo$index.cond) == length(index.cond)){for (i in seq_along(foo$condlevels))index.cond[[i]] <- index.cond[[i]][foo$index.cond[[i]]]}else if (is.function(foo$index.cond)){FUN <- foo$index.condnplots <- length(foo$panel.args)panel.order <- numeric(nplots)for (count in seq_len(nplots)){if (is.list(foo$panel.args[[count]])){pargs <- c(foo$panel.args.common, foo$panel.args[[count]], list(...))prenames <- names(formals(FUN))if (!("..." %in% prenames)) pargs <- pargs[intersect(names(pargs), prenames)]panel.order[count] <- do.call("FUN", pargs)}else ## this happens for empty panels{is.na(panel.order) <- count # panel.order[count] <- NA}}dim(panel.order) <- sapply(foo$condlevels, length)for (i in seq_along(foo$condlevels))index.cond[[i]] <-order(apply(panel.order, i, mean, na.rm = TRUE))}else stop("Invalid value of index.cond")}list(index.cond = index.cond, perm.cond = perm.cond)}compute.layout <-function(layout, cond.max.level, skip = FALSE){if (all(skip)) stop("skip cannot be all TRUE")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] <- nplotselse{layout[1] <- cond.max.level[1]layout[2] <- cond.max.level[2]}skip <- rep(skip, length.out = 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.out = 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}compute.packet <-function(cond, levels){id <- !(do.call("pmax", lapply(cond, is.na)))stopifnot(any(id))for (i in seq_along(cond)){var <- cond[[i]]id <-id & (if (is.shingle(var))((var >= levels(var)[[levels[i]]][1]) &(var <= levels(var)[[levels[i]]][2]))else(as.numeric(var) == levels[i]))}id}