The R Project SVN
R-packages
(root)/trunk/lattice/R/cloud.R – Rev 5531
Rev 5315 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
### 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## Plan: to make things more modular than they are now. As a first## step, get a function that does a 3d transformation. Probably a good## idea to do things in terms of homogeneous coordinatesltransform3dMatrix <- function(screen, R.mat = diag(4)){rot.mat <- diag(3)screen.names <- names(screen)screen <- lapply(screen, "*", pi/180)for(i in seq_along(screen.names)) {th <- screen[[i]]cth <- cos(th)sth <- sin(th)tmp.mat <-(if (screen.names[i]=="x")matrix(c(1, 0, 0, 0, cth, sth, 0, -sth, cth), 3, 3)else if (screen.names[i]=="y")matrix(c(cth, 0, -sth, 0, 1, 0, sth, 0, cth), 3, 3)else if (screen.names[i]=="z")matrix(c(cth, sth, 0, -sth, cth, 0, 0, 0, 1), 3, 3))rot.mat <- tmp.mat %*% rot.mat}rot.mat <- cbind(rot.mat, c(0,0,0))rot.mat <- rbind(rot.mat, c(0,0,0,1))if (!missing(R.mat)) rot.mat <- rot.mat %*% R.matrot.mat}ltransform3dto3d <- function(x, R.mat, dist = 0){if (length(x) == 0) return(x)tdata <- R.mat %*% rbind(x, 1)## back to 3dtdata[1,] <- tdata[1,]/tdata[4,]tdata[2,] <- tdata[2,]/tdata[4,]tdata[3,] <- tdata[3,]/tdata[4,]## now 'perspective' x,y coordinates. z remains unmodifiedif (dist != 0) ## 1/dist = distance of eye from center{tdata[1,] <- tdata[1,] / (1/dist - tdata[3,])tdata[2,] <- tdata[2,] / (1/dist - tdata[3,])}tdata[1:3, , drop = FALSE]}prepanel.default.cloud <-function(perspective = TRUE,distance = if (perspective) 0.2 else 0,xlim, ylim, zlim,screen = list(z = 40, x = -60),R.mat = diag(4),aspect = c(1, 1),panel.aspect = 1,...,zoom = 0.8){rot.mat <- ltransform3dMatrix(screen = screen, R.mat = R.mat)aspect <- rep(aspect, length.out = 2)corners <-rbind(x = c(-1,1,1,-1,-1,1,1,-1),y = c(-1,-1,-1,-1,1,1,1,1) * aspect[1],z = c(-1,-1,1,1,-1,-1,1,1) * aspect[2])corners <- corners / (2 * max(corners)) ## contain in [-.5, .5] cubecorners <- ltransform3dto3d(corners, rot.mat, dist = distance)xrng <- range(corners[1,])yrng <- range(corners[2,])slicelen <- max(diff(xrng), diff(yrng)/ panel.aspect)list(xlim = extend.limits(xrng, length = slicelen) / zoom,ylim = extend.limits(yrng, length = panel.aspect * slicelen) / zoom,dx = 1, dy = 1)}panel.3dscatter <-function(x, y, z, rot.mat = diag(4), distance,groups = NULL,type = "p",xlim.scaled,ylim.scaled,zlim.scaled,zero.scaled,col,## eventually make all these cloud.3d$col etc (or not)col.point = if (is.null(groups)) plot.symbol$col else superpose.symbol$col,col.line = if (is.null(groups)) plot.line$col else superpose.line$col,lty = if (is.null(groups)) plot.line$lty else superpose.line$lty,lwd = if (is.null(groups)) plot.line$lwd else superpose.line$lwd,cex = if (is.null(groups)) plot.symbol$cex else superpose.symbol$cex,pch = if (is.null(groups)) "+" else superpose.symbol$pch,cross,...,subscripts = TRUE){##cloud.3d <- list(col=1, cex=1, lty=1, lwd=1, pch=1)plot.symbol <- trellis.par.get("plot.symbol")plot.line <- trellis.par.get("plot.line")superpose.symbol <- trellis.par.get("superpose.symbol")superpose.line <- trellis.par.get("superpose.line")if (!missing(col)){col.point <- colcol.line <- col}n <- length(x)if (n > 0){if (is.null(groups)){col.point <- rep(col.point, length.out = n)col.line <- rep(col.line, length.out = n)lty <- rep(lty, length.out = n)lwd <- rep(lwd, length.out = n)cex <- rep(cex, length.out = n)pch <- rep(pch, length.out = n)}else{nvals <- nlevels(as.factor(groups))groups <- as.numeric(as.factor(groups))[subscripts]col.point <- rep(col.point, length.out = nvals)[groups]col.line <- rep(col.line, length.out = nvals)[groups]lty <- rep(lty, length.out = nvals)[groups]lwd <- rep(lwd, length.out = nvals)[groups]cex <- rep(cex, length.out = nvals)[groups]pch <- rep(pch, length.out = nvals)[groups]}## The following code deals with different 'type's. (We allow## for multiple types, but do them sequentially, so## overplotting may happen. The amount of work required to fix## this is too much to make it worth the effort.)## 'points' typeif (any(c("p", "b", "o") %in% type)){id <-((x >= xlim.scaled[1]) & (x <= xlim.scaled[2]) &(y >= ylim.scaled[1]) & (y <= ylim.scaled[2]) &(z >= zlim.scaled[1]) & (z <= zlim.scaled[2]) &!is.na(x) & !is.na(y) & !is.na(z))m <- ltransform3dto3d(rbind(x, y, z), rot.mat, distance)ord <- sort.list(m[3,])ord <- ord[id[ord]]if (missing(cross)) cross <- all(pch == "+")if (cross) ## plot symbols are 3d cross hairs{tmpx0 <- rep(x[ord], each = 3) - rep(cex[ord], each = 3) * c(0.02, 0, 0)tmpx1 <- rep(x[ord], each = 3) + rep(cex[ord], each = 3) * c(0.02, 0, 0)tmpy0 <- rep(y[ord], each = 3) - rep(cex[ord], each = 3) * c(0, 0.02, 0)tmpy1 <- rep(y[ord], each = 3) + rep(cex[ord], each = 3) * c(0, 0.02, 0)tmpz0 <- rep(z[ord], each = 3) - rep(cex[ord], each = 3) * c(0, 0, 0.02)tmpz1 <- rep(z[ord], each = 3) + rep(cex[ord], each = 3) * c(0, 0, 0.02)m0 <- ltransform3dto3d(rbind(tmpx0, tmpy0, tmpz0), rot.mat, distance)m1 <- ltransform3dto3d(rbind(tmpx1, tmpy1, tmpz1), rot.mat, distance)lsegments(x0 = m0[1,], y0 = m0[2,],x1 = m1[1,], y1 = m1[2,],col = rep(col.line[ord], each = 3))}else{lpoints(x = m[1, ord], y = m[2, ord],col = col.point[ord],pch = pch[ord],cex = cex[ord])}}## 'lines' typeif (any(c("l", "b", "o") %in% type)){ord <- if (is.null(groups)) TRUE else sort.list(groups)tmplen <- length(x)tmpx0 <- x[ord][-1]tmpx1 <- x[ord][-tmplen]tmpy0 <- y[ord][-1]tmpy1 <- y[ord][-tmplen]tmpz0 <- z[ord][-1]tmpz1 <- z[ord][-tmplen]tmpcol0 <- col.line[ord][-1]tmpcol1 <- col.line[ord][-tmplen]## segments shouldn't join points in different groupstmpcol0[ groups[ord][-1] != groups[ord][-tmplen] ] <- "transparent"m0 <- ltransform3dto3d(rbind(tmpx0, tmpy0, tmpz0), rot.mat, distance)m1 <- ltransform3dto3d(rbind(tmpx1, tmpy1, tmpz1), rot.mat, distance)## a collection of line segments in 3d space is not well## ordered. This is just a naive heuristic:ord <- sort.list(pmax(m0[3,], m1[3,]))lsegments(x0 = m0[1, ord], y0 = m0[2, ord],x1 = m1[1, ord], y1 = m1[2, ord],col = tmpcol0[ord])}## 'histogram' typeif ("h" %in% type){id <-((x >= xlim.scaled[1]) & (x <= xlim.scaled[2]) &(y >= ylim.scaled[1]) & (y <= ylim.scaled[2]) &!is.na(x) & !is.na(y) & !is.na(z))m <- ltransform3dto3d(rbind(x, y, z), rot.mat, distance)ord <- sort.list(m[3,])ord <- ord[id[ord]]zero.scaled <-if (zero.scaled < zlim.scaled[1]) zlim.scaled[1]else if (zero.scaled > zlim.scaled[2]) zlim.scaled[2]else zero.scaledother.end <- ltransform3dto3d(rbind(x, y, zero.scaled), rot.mat, distance)lsegments(m[1,ord], m[2,ord],other.end[1,ord], other.end[2,ord],col = col.line[ord],lty = lty[ord],lwd = lwd[ord])}if (any(!(type %in% c("p", "h", "l", "b", "o")))){warning("'type' has unsupported values")}}}###################################################################### Interface to C code ######################################################################## the following is now part of the settings# palette.shade <-# function(irr, ref, height, saturation = .9)# {# hsv(h = height,# s = 1 - saturation * (1 - (1-ref)^0.5),# v = irr)# }panel.3dwire <-function(x, y, z, rot.mat = diag(4), distance,shade = FALSE,shade.colors.palette = trellis.par.get("shade.colors")$palette,light.source = c(0, 0, 1000),xlim.scaled,ylim.scaled,zlim.scaled,col = if (shade) "transparent" else "black",lty = 1, lwd = 1,alpha,col.groups = superpose.polygon$col,polynum = 100,...,drape = FALSE,at,col.regions = regions$col,alpha.regions = regions$alpha){## a faster version of panel.3dwire that takes advantage of grid## in R >= 1.8.1's multiple polygon drawing capabilities. The## solution is a bit hackish, it basically keeps track of the## polygons to be drawn in a 'global' variable and draws them all## at once when 'sufficiently many' have been collected.## x, y, z are in a special form here (compared to most other## places in lattice). x and y are short ascending, describing the## grid, and z is the corresponding z values in the order (x1,y1),## (x1,y2), ... . length(z) == length(x) * length(y). Sometimes, z## might be a matrix, which indicates multiple surfaces. Above## description true for each column in that case.## things are slightly different depending on whether shading is## being done. If not, things are relatively simple, and in## particular polygons are drawn one quadrilateral at a## time. However, if shade=T, facets are drawn triangles at a## time. The difference is mostly in C code, but some distinctions## need to be made here as wellif (shade) drape <- FALSE ## shade overrides draperegions <-if (drape)trellis.par.get("regions")else {bg <- trellis.par.get("background")if (bg[["col"]] == "transparent")bg[["col"]] <- "white"bg}numcol <- length(at) - 1numcol.r <- length(col.regions)col.regions <-if (numcol.r <= numcol)rep(col.regions, length.out = numcol)else col.regions[floor(1+(1:numcol-1)*(numcol.r-1)/(numcol-1))]## 2004-03-12 new experimental stuff: when x, y, z are all## matrices of the same dimension, they represent a 3-D surface## parametrized on a 2-D grid (the details of the parametrizing## grid are unimportant).isParametrizedSurface <- is.matrix(x) && is.matrix(y) && is.matrix(z)if (isParametrizedSurface){is.na(x) <- (x < xlim.scaled[1] | x > xlim.scaled[2])is.na(y) <- (y < ylim.scaled[1] | y > ylim.scaled[2])is.na(z) <- (z < zlim.scaled[1] | z > zlim.scaled[2])htrange <- extend.limits(sqrt(range(x^2 + y^2 + z^2, finite = TRUE)), prop = 0.01)ngroups <- 1}else{ngroups <- if (is.matrix(z)) ncol(z) else 1superpose.polygon <- trellis.par.get("superpose.polygon")col.groups <- rep(col.groups, length.out = ngroups)if (length(col) > 1) col <- rep(col, length.out = ngroups)## remove things outside xlim and ylim boundsid.x <- x >= xlim.scaled[1] & x <= xlim.scaled[2]id.y <- y >= ylim.scaled[1] & y <= ylim.scaled[2]id.z <- rep(id.y, length(id.x)) & rep(id.x, each = length(id.y))x <- x[id.x]y <- y[id.y]z <- z[id.z]htrange <- zlim.scaled}if (shade){shade.colors.palette <-if (is.character(shade.colors.palette)) get(shade.colors.palette)else eval(shade.colors.palette)pol.x <- numeric(polynum * 3)pol.y <- numeric(polynum * 3)pol.fill <- character(polynum)pol.col <- colpol.alpha <- trellis.par.get("shade.colors")$alphaif (!missing(alpha)) pol.alpha <- alphacount <- 0 ## counts number of polygons stacked up so farwirePolygon <-function(xx, yy, misc){## misc:## 1: cos angle between normal and incident light## 2: cos angle between reflected light and eye## 3: z-height averaged## 4: group indicatorheight <- (misc[3] - htrange[1]) / diff(htrange)invalid <- (is.na(height) || any(is.na(xx)) ||any(is.na(yy)) || height > 1 || height < 0)if (!invalid){pol.x[3 * count + 1:3] <<- xxpol.y[3 * count + 1:3] <<- yycount <<- count + 1pol.fill[count] <<-shade.colors.palette(misc[1], misc[2], height)if (count == polynum){grid.polygon(x = pol.x, y = pol.y, id.lengths = rep(3, polynum),default.units = "native",gp = gpar(fill = pol.fill,col = pol.col,lty = lty, lwd = lwd,alpha = pol.alpha))count <<- 0}}}.Call(wireframePanelCalculations,as.double(x),as.double(y),as.double(z),as.double(rot.mat),as.double(distance),if (isParametrizedSurface) as.integer(ncol(x)) else as.integer(length(x)),if (isParametrizedSurface) as.integer(nrow(x)) else as.integer(length(y)),as.integer(ngroups),as.double(light.source),environment(),as.integer(shade),as.integer(isParametrizedSurface))if (count > 0){grid.polygon(x = pol.x[1:(count * 3)], y = pol.y[1:(count * 3)],default.units = "native", id.lengths = rep(3, count),gp = gpar(fill = rep(pol.fill, length.out = count),col = rep(pol.col, length.out = count),lty = lty, lwd = lwd,alpha = pol.alpha))}}else ## no shade{pol.x <- numeric(polynum * 4)pol.y <- numeric(polynum * 4)if (length(col.regions) > 1){pol.fill <- vector(mode(col.regions), polynum)pol.col <-if (ngroups == 1 || length(col) == 1) col[1]else vector(mode(col), polynum)pol.alpha <- alpha.regions}else if (ngroups == 1){pol.fill <- col.regions[1]pol.col <- col[1]pol.alpha <- alpha.regions}else{pol.fill <- vector(mode(col.groups), polynum)pol.col <-if (length(col) == 1) col[1]else vector(mode(col), polynum)pol.alpha <- superpose.polygon$alpha}## FIXME: should alpha override alpha.regions?if (!missing(alpha)) pol.alpha <- alphacount <- 0 ## counts number of polygons stacked up so farwirePolygon <-function(xx, yy, misc){## misc:## 3: z-height averaged## 4: group indicatorheight <- (misc[3] - htrange[1]) / diff(htrange)invalid <- (is.na(height) || any(is.na(xx)) || any(is.na(yy)) ||height > 1 || height < 0)if (!invalid){pol.x[4 * count + 1:4] <<- xxpol.y[4 * count + 1:4] <<- yycount <<- count + 1if (length(col.regions) > 1){pol.fill[count] <<- col.regions[(seq_along(at)[at > misc[3]])[1] - 1 ]if (ngroups > 1 && length(col) > 1) pol.col[count] <<- col[as.integer(misc[4])]}## nothing to do if ngroups == 1else if (ngroups > 1){pol.fill[count] <<- col.groups[as.integer(as.integer(misc[4]))]if (length(col) > 1) pol.col[count] <<- col[as.integer(misc[4])]}if (count == polynum) {grid.polygon(x = pol.x, y = pol.y, id.lengths = rep(4, polynum),default.units = "native",gp = gpar(fill = pol.fill,col = pol.col,lty = lty, lwd = lwd,alpha = pol.alpha))count <<- 0}}}.Call(wireframePanelCalculations,as.double(x),as.double(y),as.double(z),as.double(rot.mat),as.double(distance),if (isParametrizedSurface) as.integer(ncol(x)) else as.integer(length(x)),if (isParametrizedSurface) as.integer(nrow(x)) else as.integer(length(y)),as.integer(ngroups),as.double(light.source),environment(),as.integer(shade),as.integer(isParametrizedSurface))if (count > 0){grid.polygon(x = pol.x[1:(count * 4)], y = pol.y[1:(count * 4)],default.units = "native", id.lengths = rep(4, count),gp = gpar(fill = rep(pol.fill, length.out = count),col = rep(pol.col, length.out = count),lty = lty, lwd = lwd,alpha = pol.alpha))}}}panel.cloud <-function(x, y, subscripts, z,groups = NULL,perspective = TRUE,distance = if (perspective) 0.2 else 0,xlim, ylim, zlim,panel.3d.cloud = "panel.3dscatter",panel.3d.wireframe = "panel.3dwire",screen = list(z = 40, x = -60),R.mat = diag(4), aspect = c(1, 1),par.box = NULL,xlab, ylab, zlab,xlab.default, ylab.default, zlab.default,scales.3d,proportion = 0.6, wireframe = FALSE,## zoom = 0.8, ## ignored in panel.cloud## The main problem with scales is that it is difficult## to figure out the best way to place the scales. They## can be specified explicitly using scpos if default is## not OKscpos,...,at) ## this is same as 'at' in wireframe{## x, y, z can be matrices and we want to retain them as matrices.## The only reasonable things (other than already numeric) are## factors. Other things will hopefully cause an error down the## road, and we may want to catch them here some day.if (is.factor(x)) x <- as.numeric(x)if (is.factor(y)) y <- as.numeric(y)if (is.factor(z)) z <- as.numeric(z)## calculate rotation matrix:rot.mat <- ltransform3dMatrix(screen = screen, R.mat = R.mat)## 2004-03-12 new experimental stuff: when x, y, z are all## matrices of the same dimension, they represent a 3-D surface## parametrized on a 2-D grid (the details of the parametrizing## grid are unimportant). This is meant only for wireframe## In this case, subscripts will be ignored, because it's not## clear how they should interactisParametrizedSurface <-wireframe && is.matrix(x) && is.matrix(y) && is.matrix(z)if (isParametrizedSurface)zrng <- extend.limits(sqrt(range(x^2 + y^2 + z^2, finite = TRUE)))if (length(subscripts) > 0) ## otherwise nothing to draw (not even box ?){## figure out data ranges and tick locations / labels## Information needed: *lim, scales.3d## For now, keep *lim as they are, since in cloud / wireframe## extend.limits type adjustments don't happen by## default. Even if that's done, this may not be the place to## do it (shouldn't really need anything more than *lim and## *axs)## So, get tick labels, and then convert *lim to numeric## Although, this is all unnecessary if arrows = TRUExlabelinfo <-calculateAxisComponents(xlim,at = scales.3d$x$at,num.limit = NULL,labels = scales.3d$x$labels,logsc = scales.3d$x$log,abbreviate = scales.3d$x$abbreviate,minlength = scales.3d$x$minlength,format.posixt = scales.3d$x$format,n = scales.3d$x$tick.number)ylabelinfo <-calculateAxisComponents(ylim,at = scales.3d$y$at,num.limit = NULL,labels = scales.3d$y$labels,logsc = scales.3d$y$log,abbreviate = scales.3d$y$abbreviate,minlength = scales.3d$y$minlength,format.posixt = scales.3d$y$format,n = scales.3d$y$tick.number)zlabelinfo <-calculateAxisComponents(zlim,at = scales.3d$z$at,num.limit = NULL,labels = scales.3d$z$labels,logsc = scales.3d$z$log,abbreviate = scales.3d$z$abbreviate,minlength = scales.3d$z$minlength,format.posixt = scales.3d$z$format,n = scales.3d$z$tick.number)x.at <- xlabelinfo$aty.at <- ylabelinfo$atz.at <- zlabelinfo$atx.at.lab <- xlabelinfo$laby.at.lab <- ylabelinfo$labz.at.lab <- zlabelinfo$labxlim <- xlabelinfo$num.limitylim <- ylabelinfo$num.limitzlim <- zlabelinfo$num.limitpar.box.final <- trellis.par.get("box.3d")if (!is.null(par.box)) par.box.final[names(par.box)] <- par.boxaspect <- rep(aspect, length.out = 2)if (!isParametrizedSurface){x <- x[subscripts]y <- y[subscripts]z <- z[subscripts]}corners <-data.frame(x = c(-1, 1, 1,-1,-1, 1, 1,-1),y = c(-1,-1,-1,-1, 1, 1, 1, 1) * aspect[1],z = c(-1,-1, 1, 1,-1,-1, 1, 1) * aspect[2])corners <- corners / (2 * max(corners)) ## contain in [-.5, .5] cubexlim.scaled <- range(corners$x)ylim.scaled <- range(corners$y)zlim.scaled <- range(corners$z)## denotes scaled ranges of bounding box. passed to## panel.3dscatter and panel.3dwire in case they are useful## center of bounding box:box.center <- matrix(unlist(lapply(corners, mean)), 3, 1)## these are box boundaries:pre <- c(1,2,4,1,2,3,4,1,5,6,8,5)nxt <- c(2,3,3,4,6,7,8,5,6,7,7,8)## The corners are defined in terms of coordinates in 3-D## space as above. The actual choice of coordinates ideally## should not affect anything, but I haven't checked. Box## boundaries are defined as pairs of corners. The numbers of## the corners and boundaries are helpful in keeping track of## things, and are described in the diagram below.## 1, 2, ..., 8 are the corners, L-1, ..., L-12 the boundaries#### L-11## 8------------------------7## / | / |## / | / |## L-7/ |L-12 L-6/ |## / | / |## / | / |## / | L-3 / |L-10## 4-------------------------3 |## | | | |## | | | |## | | | |## | | L-9 | |## L-4| 5-----------------|-------6## | / | /## | / | /## | / L-2| /L-5## | / | /## | /L-8 | /## | / | /## |/ |/## 1-------------------------2## (0,0,0) L-1###### Also the 6 FACES are defined in terms of corners (lines)## as follows:#### F-1 : 1,2,3,4 (1,2,3,4)## F-2 : 2,6,7,3 (5,10,6,2)## F-3 : 6,5,8,7 (9,12,11,10)## F-4 : 5,1,4,8 (8,4,7,12)## F-5 : 1,2,6,5 (1,5,9,8)## F-6 : 4,3,7,8 (3,6,11,7)face.corners <- list(c(1,2,3,4),c(2,6,7,3),c(6,5,8,7),c(5,1,4,8),c(1,2,6,5),c(4,3,7,8))face.lines <- list(c(1,2,3,4),c(5,10,6,2),c(9,12,11,10),c(8,4,7,12),c(1,5,9,8),c(3,6,11,7))## SCALES : very betatmp <- ltransform3dto3d(t(as.matrix(corners)), rot.mat)farthest <- 1 ## used later alsofarval <- tmp[3,1]for (i in 2:8)if (tmp[3,i] < farval) {farthest <- ifarval <- tmp[3,i]}## not foolproof, need to revisit this laterscale.position <-if (farthest == 1) list(x = 3, y = 7, z = 2)else if (farthest == 2) list(x = 9, y = 8, z = 10)else if (farthest == 3) list(x = 11, y = 7, z = 10)else if (farthest == 4) list(x = 11, y = 6, z = 2)else if (farthest == 5) list(x = 1, y = 5, z = 4)else if (farthest == 6) list(x = 1, y = 8, z = 12)else if (farthest == 7) list(x = 3, y = 7, z = 2)else if (farthest == 8) list(x = 3, y = 6, z = 10)##original:#if (farthest == 1) list(x = 9, y = 5, z = 2)#else if (farthest == 2) list(x = 9, y = 8, z = 10)#else if (farthest == 3) list(x = 11, y = 7, z = 10)#else if (farthest == 4) list(x = 11, y = 6, z = 2)#else if (farthest == 5) list(x = 1, y = 5, z = 4)#else if (farthest == 6) list(x = 1, y = 8, z = 12)#else if (farthest == 7) list(x = 3, y = 7, z = 2)#else if (farthest == 8) list(x = 3, y = 6, z = 10)if (!missing(scpos))scale.position[names(scpos)] <- scposscpos <- scale.positionlabs <- rbind(x = c(0, corners$x[pre[scpos$y]], corners$x[pre[scpos$z]]),y = c(corners$y[pre[scpos$x]], 0, corners$y[pre[scpos$z]]),z = c(corners$z[pre[scpos$x]], corners$z[pre[scpos$y]], 0))labs[,1] <- labs[,1] * (1 + scales.3d$x.scales$distance/3)labs[,2] <- labs[,2] * (1 + scales.3d$y.scales$distance/3)labs[,3] <- labs[,3] * (1 + scales.3d$z.scales$distance/3)axes <- rbind(x =c(proportion * corners$x[c(pre[scpos$x], nxt[scpos$x])],corners$x[c(pre[scpos$y], nxt[scpos$y])],corners$x[c(pre[scpos$z], nxt[scpos$z])]),y =c(corners$y[c(pre[scpos$x], nxt[scpos$x])],proportion * corners$y[c(pre[scpos$y], nxt[scpos$y])],corners$y[c(pre[scpos$z], nxt[scpos$z])]),z =c(corners$z[c(pre[scpos$x], nxt[scpos$x])],corners$z[c(pre[scpos$y], nxt[scpos$y])],proportion * corners$z[c(pre[scpos$z], nxt[scpos$z])]))axes[,1:2] <- axes[,1:2] * (1 + scales.3d$x.scales$distance/10)axes[,3:4] <- axes[,3:4] * (1 + scales.3d$y.scales$distance/10)axes[,5:6] <- axes[,5:6] * (1 + scales.3d$z.scales$distance/10)## box ranges and lengthscmin <- lapply(corners, min)cmax <- lapply(corners, max)clen <- lapply(corners, function(x) diff(range(x, finite = TRUE)))## scaled (to bounding box) datax <- cmin$x + clen$x * (x-xlim[1])/diff(xlim)y <- cmin$y + clen$y * (y-ylim[1])/diff(ylim)z <- cmin$z + clen$z * (z-zlim[1])/diff(zlim)at <-if (isParametrizedSurface){zrng.scaled <- extend.limits(sqrt(range(x^2 + y^2 + z^2, finite = TRUE)))zrng.scaled[1] + diff(zrng.scaled) * (at - zrng[1])/diff(zrng)}else cmin$z + clen$z * (at - zlim[1])/diff(zlim)## same?: zero.scaled <- cmin$z + clen$z * (0 - zlim[1])/diff(zlim)## yes. cmin$z - clen$z * zlim[1]/diff(zlim)zero.scaled <- cmin$z - clen$z * zlim[1]/diff(zlim)## needed in panel.3dscatter for type = 'h'x.at <- cmin$x + clen$x * (x.at-xlim[1])/diff(xlim)y.at <- cmin$y + clen$y * (y.at-ylim[1])/diff(ylim)z.at <- cmin$z + clen$z * (z.at-zlim[1])/diff(zlim)at.len <- length(x.at)x.at <- rbind(x = x.at,y = rep(corners$y[pre[scpos$x]], at.len),z = rep(corners$z[pre[scpos$x]], at.len))at.len <- length(y.at)y.at <- rbind(x = rep(corners$x[pre[scpos$y]], at.len),y = y.at,z = rep(corners$z[pre[scpos$y]], at.len))at.len <- length(z.at)z.at <- rbind(x = rep(corners$x[pre[scpos$z]], at.len),y = rep(corners$y[pre[scpos$z]], at.len),z = z.at)x.at.end <- x.at + scales.3d$x.scales$tck * .05 * labs[,1]y.at.end <- y.at + scales.3d$y.scales$tck * .05 * labs[,2]z.at.end <- z.at + scales.3d$z.scales$tck * .05 * labs[,3]x.labs <- x.at + 2 * scales.3d$x.scales$tck * .05 * labs[,1]y.labs <- y.at + 2 * scales.3d$y.scales$tck * .05 * labs[,2]z.labs <- z.at + 2 * scales.3d$z.scales$tck * .05 * labs[,3]corners <- ltransform3dto3d(t(as.matrix(corners)), rot.mat, distance)taxes <- ltransform3dto3d(axes, rot.mat, distance)x.at <- ltransform3dto3d(x.at, rot.mat, distance)x.labs <- ltransform3dto3d(x.labs, rot.mat, distance)x.at.end <- ltransform3dto3d(x.at.end, rot.mat, distance)y.at <- ltransform3dto3d(y.at, rot.mat, distance)y.labs <- ltransform3dto3d(y.labs, rot.mat, distance)y.at.end <- ltransform3dto3d(y.at.end, rot.mat, distance)z.at <- ltransform3dto3d(z.at, rot.mat, distance)z.labs <- ltransform3dto3d(z.labs, rot.mat, distance)z.at.end <- ltransform3dto3d(z.at.end, rot.mat, distance)tlabs <- ltransform3dto3d(labs, rot.mat, distance)box.center <- ltransform3dto3d(box.center, rot.mat, distance)## Shall now determine which bounding lines should be 'hidden'## (by the data, and hence need to be drawn before the data),## and which should be 'visible'. Will actually consider each## face (one at a time), determine if it is 'visible' (had the## bounding cube been opaque), and if so, mark the lines## forming that face as 'visible'## The logical vector 'mark' will correspond to the 12 lines## (indexing explained in the diagram above). mark = TRUE will## mean that the line will be drawn AFTER the data is## drawn. Start off with all mark = FALSE.## The idea is that for visible faces, the z-value of the## center of the face will be greater than the z-value of the## center of the whole box. This doesn't always work for## perspective plots.##print(box.center)mark <- rep(FALSE, 12)box.center.z <- box.center[3]for (face in 1:6)if (mean(corners[3, face.corners[[face]] ]) > box.center.z) ## i.e., face visiblemark[1:12 %in% face.lines[[face]] ] <- TRUE#for (j in 1:12)# if (pre[j]==farthest || nxt[j]==farthest)# mark[j] <- FALSE## This draws the 'back' of the box, i.e., the portion that## should be hidden by the data. This doesn't always work## properlylsegments(corners[1, pre[!mark]],corners[2, pre[!mark]],corners[1, nxt[!mark]],corners[2, nxt[!mark]],col = par.box.final$col,lwd = par.box.final$lwd,lty = 2)## The following portion of code is responsible for drawing## the part of the plot driven by the data. The modus operandi## will be different for cloud and wireframe, since they have## essentially different purpose. For cloud, the data is## unstructured, and x, y and z are all passed to the## panel.3d.cloud function. For wireframe, on the other hand,## x and y must form a regular grid, which sort(unique(<x|y>))## is enough to describe (o.w., greater chances of memory## problems). z would then have to be supplied in a very## particular order. All this is fine, but a problem arises if## we want to allow groups -- multiple surfaces. One option is## to supply a matrix (nx * ny by no.of.groups) for z. This is## OK, but it precludes the posibility of supplying x and y as## only their unique values from the very beginning. So that's## not allowed for grouped displaysif (wireframe){if (isParametrizedSurface){## FIXME: unnecessary copytmp <- z}else if (is.null(groups)){nx <- length(unique(x))ny <- length(unique(y))len <- length(z)if (nx * ny == len){ord <- order(x, y)tmp <- z[ord]x <- sort(unique(x[!is.na(x)]))y <- sort(unique(y[!is.na(y)]))}else{## which means some rows missing, should be NA## convert z into a (conceptual) matrix, with NA## entries for those 'missing' from data## frame. There's scope for ambiguity here, which## can be avoided by the user.tmp <- rep(NA_real_, nx * ny)ux <- sort(unique(x[!is.na(x)]))uy <- sort(unique(y[!is.na(y)]))idx <- match(x, ux)idy <- match(y, uy)tmp[(idx - 1) * length(uy) + idy] <- zx <- uxy <- uy}}else {## all surfaces have to be on the same regular## grid. No row can be missing, though some z-values## can be NA. Needs a lot of change otherwisevals <- sort(unique(groups))nvals <- length(vals)tmp <- numeric(0)for (i in seq_along(vals)) {id <- (groups[subscripts] == vals[i])if (any(id)) {ord <- order(x[id], y[id])tmp <- cbind(tmp, z[id][ord])}}x <- sort(unique(x))y <- sort(unique(y))}z <- list(NULL) ## hopefully becomes garbage, collected if necessarypanel.3d.wireframe <-if (is.character(panel.3d.wireframe)) get(panel.3d.wireframe)else eval(panel.3d.wireframe)pargs <- list(x = x, y = y, z = tmp,rot.mat = rot.mat,distance = distance,at = at,## col.regions = col.regions,xlim = xlim,ylim = ylim,zlim = zlim,xlim.scaled = xlim.scaled,ylim.scaled = ylim.scaled,zlim.scaled = zlim.scaled,zero.scaled = zero.scaled,...)if (!("..." %in% names(formals(panel.3d.wireframe))))pargs <- pargs[intersect(names(pargs), names(formals(panel.3d.wireframe)))]do.call("panel.3d.wireframe", pargs)}else {panel.3d.cloud <-if (is.character(panel.3d.cloud)) get(panel.3d.cloud)else eval(panel.3d.cloud)pargs <- list(x = x, y = y, z = z,rot.mat = rot.mat,distance = distance,groups = groups,subscripts = subscripts,xlim = xlim,ylim = ylim,zlim = zlim,xlim.scaled = xlim.scaled,ylim.scaled = ylim.scaled,zlim.scaled = zlim.scaled,zero.scaled = zero.scaled,...)if (!("..." %in% names(formals(panel.3d.cloud))))pargs <- pargs[intersect(names(pargs), names(formals(panel.3d.cloud)))]do.call("panel.3d.cloud", pargs)}## This draws the front of the bounding boxlsegments(corners[1, pre[mark]],corners[2, pre[mark]],corners[1, nxt[mark]],corners[2, nxt[mark]],col = par.box.final$col,lty = par.box.final$lty,lwd = par.box.final$lwd)## Next part for axesaxis.text <- trellis.par.get("axis.text")axis.line <- trellis.par.get("axis.line")xaxis.col.line <-if (is.logical(scales.3d$x.scales$col.line)) axis.line$colelse scales.3d$x.scales$col.linexaxis.lty <-if (is.logical(scales.3d$x.scales$lty)) axis.line$lwdelse scales.3d$x.scales$ltyxaxis.lwd <-if (is.logical(scales.3d$x.scales$lwd)) axis.line$ltyelse scales.3d$x.scales$lwdxaxis.col.text <-if (is.logical(scales.3d$x.scales$col)) axis.text$colelse scales.3d$x.scales$colxaxis.font <-if (is.logical(scales.3d$x.scales$font)) axis.text$fontelse scales.3d$x.scales$fontxaxis.fontface <-if (is.logical(scales.3d$x.scales$fontface)) axis.text$fontfaceelse scales.3d$x.scales$fontfacexaxis.fontfamily <-if (is.logical(scales.3d$x.scales$fontfamily)) axis.text$fontfamilyelse scales.3d$x.scales$fontfamilyxaxis.cex <-if (is.logical(scales.3d$x.scales$cex)) rep(axis.text$cex, length.out = 1)else scales.3d$x.scales$cexxaxis.rot <-if (is.logical(scales.3d$x.scales$rot)) 0else scales.3d$x.scales$rotyaxis.col.line <-if (is.logical(scales.3d$y.scales$col.line)) axis.line$colelse scales.3d$y.scales$col.lineyaxis.lty <-if (is.logical(scales.3d$y.scales$lty)) axis.line$lwdelse scales.3d$y.scales$ltyyaxis.lwd <-if (is.logical(scales.3d$y.scales$lwd)) axis.line$ltyelse scales.3d$y.scales$lwdyaxis.col.text <-if (is.logical(scales.3d$y.scales$col)) axis.text$colelse scales.3d$y.scales$colyaxis.font <-if (is.logical(scales.3d$y.scales$font)) axis.text$fontelse scales.3d$y.scales$fontyaxis.fontface <-if (is.logical(scales.3d$y.scales$fontface)) axis.text$fontfaceelse scales.3d$y.scales$fontfaceyaxis.fontfamily <-if (is.logical(scales.3d$y.scales$fontfamily)) axis.text$fontfamilyelse scales.3d$y.scales$fontfamilyyaxis.cex <-if (is.logical(scales.3d$y.scales$cex)) rep(axis.text$cex, length.out = 1)else scales.3d$y.scales$cexyaxis.rot <-if (is.logical(scales.3d$y.scales$rot)) 0else scales.3d$y.scales$rotzaxis.col.line <-if (is.logical(scales.3d$z.scales$col.line)) axis.line$colelse scales.3d$z.scales$col.linezaxis.lty <-if (is.logical(scales.3d$z.scales$lty)) axis.line$lwdelse scales.3d$z.scales$ltyzaxis.lwd <-if (is.logical(scales.3d$z.scales$lwd)) axis.line$ltyelse scales.3d$z.scales$lwdzaxis.col.text <-if (is.logical(scales.3d$z.scales$col)) axis.text$colelse scales.3d$z.scales$colzaxis.font <-if (is.logical(scales.3d$z.scales$font)) axis.text$fontelse scales.3d$z.scales$fontzaxis.fontface <-if (is.logical(scales.3d$z.scales$fontface)) axis.text$fontfaceelse scales.3d$z.scales$fontfacezaxis.fontfamily <-if (is.logical(scales.3d$z.scales$fontfamily)) axis.text$fontfamilyelse scales.3d$z.scales$fontfamilyzaxis.cex <-if (is.logical(scales.3d$z.scales$cex)) rep(axis.text$cex, length.out = 1)else scales.3d$z.scales$cexzaxis.rot <-if (is.logical(scales.3d$z.scales$rot)) 0else scales.3d$z.scales$rotif (scales.3d$x.scales$draw) {if (scales.3d$x.scales$arrows) {larrows(x0 = taxes[1, 1], y0 = taxes[2, 1],x1 = taxes[1, 2], y1 = taxes[2, 2],length = 0.02, unit = "npc",lty = xaxis.lty,lwd = xaxis.lwd,col = xaxis.col.line)}else {lsegments(x0 = x.at[1,], y0 = x.at[2,], x1 = x.at.end[1,], y1 = x.at.end[2,],lty = xaxis.lty,col = xaxis.col.line,lwd = xaxis.lwd)ltext(x.at.lab, x = x.labs[1,], y = x.labs[2,],cex = xaxis.cex,srt = xaxis.rot,font = xaxis.font,fontfamily = xaxis.fontfamily,fontface = xaxis.fontface,col = xaxis.col.text)}}if (scales.3d$y.scales$draw) {if (scales.3d$y.scales$arrows) {larrows(x0 = taxes[1, 3], y0 = taxes[2, 3],x1 = taxes[1, 4], y1 = taxes[2, 4],length = 0.02, unit = "npc",lty = yaxis.lty,lwd = yaxis.lwd,col = yaxis.col.line)}else {lsegments(x0 = y.at[1,], y0 = y.at[2,], x1 = y.at.end[1,], y1 = y.at.end[2,],lty = yaxis.lty,col = yaxis.col.line,lwd = yaxis.lwd)ltext(y.at.lab, x = y.labs[1,], y = y.labs[2,],cex = yaxis.cex,srt = yaxis.rot,font = yaxis.font,fontfamily = yaxis.fontfamily,fontface = yaxis.fontface,col = yaxis.col.text)}}if (scales.3d$z.scales$draw) {if (scales.3d$z.scales$arrows) {larrows(x0 = taxes[1, 5], y0 = taxes[2, 5],x1 = taxes[1, 6], y1 = taxes[2, 6],length = 0.02, unit = "npc",lty = zaxis.lty,lwd = zaxis.lwd,col = zaxis.col.line)}else {lsegments(x0 = z.at[1,], y0 = z.at[2,], x1 = z.at.end[1,], y1 = z.at.end[2,],lty = zaxis.lty,col = zaxis.col.line,lwd = zaxis.lwd)ltext(z.at.lab, x = z.labs[1,], y = z.labs[2,],cex = zaxis.cex,srt = zaxis.rot,font = zaxis.font,fontfamily = zaxis.fontfamily,fontface = zaxis.fontface,col = zaxis.col.text)}}xlab <- getLabelList(xlab, trellis.par.get("par.xlab.text"), xlab.default)ylab <- getLabelList(ylab, trellis.par.get("par.ylab.text"), ylab.default)zlab <- getLabelList(zlab, trellis.par.get("par.zlab.text"), zlab.default)## slightly different frm xyplot etc, in that rot can be## supplied in the *lab listsxlab <-grobFromLabelList(xlab, name = trellis.grobname("xlab"))# rot = if (is.null(xlab$rot)) 0 else xlab$rot)ylab <-grobFromLabelList(ylab, name = trellis.grobname("ylab"))# rot = if (is.null(ylab$rot)) 0 else ylab$rot)zlab <-grobFromLabelList(zlab, name = trellis.grobname("zlab"))# rot = if (is.null(zlab$rot)) 0 else zlab$rot)if (!is.null(xlab)){pushViewport(viewport(x = tlabs[1, 1], y = tlabs[2, 1],default.units = "native"))grid.draw(xlab)upViewport()}if (!is.null(ylab)){pushViewport(viewport(x = tlabs[1, 2], y = tlabs[2, 2],default.units = "native"))grid.draw(ylab)upViewport()}if (!is.null(zlab)){pushViewport(viewport(x = tlabs[1, 3], y = tlabs[2, 3],default.units = "native"))grid.draw(zlab)upViewport()}}}panel.wireframe <- function(...)panel.cloud(..., wireframe = TRUE)wireframe <- function(x, data, ...) UseMethod("wireframe")wireframe.matrix <-function(x, data = NULL,zlab = deparse(substitute(x)),aspect,..., xlim, ylim,row.values = seq_len(nrow(x)),column.values = seq_len(ncol(x))){stopifnot(length(row.values) == nrow(x),length(column.values) == ncol(x))if (!is.null(data)) warning("explicit 'data' specification ignored")form <- eval(z ~ row * column)if (missing(aspect)) aspect <- pmin(ncol(x) / nrow(x), c(Inf, 1))data <- expand.grid(row = row.values, column = column.values)data$z <- as.vector(as.numeric(x))## if rownames/colnames are non-null, use them to labelif (missing(xlim))xlim <-if (!is.null(rownames(x))) rownames(x)else range(row.values, finite = TRUE)if (missing(ylim))ylim <-if (!is.null(colnames(x))) colnames(x)else range(column.values, finite = TRUE)wireframe(form, data, zlab = zlab, aspect = aspect,xlim = xlim, ylim = ylim,...)}wireframe.formula <-function(x,data = NULL,panel = lattice.getOption("panel.wireframe"),...){ocall <- sys.call(sys.parent()); ocall[[1]] <- quote(wireframe)ccall <- match.call()ccall$data <- dataccall$panel <- panelccall[[1]] <- quote(lattice::cloud)ans <- eval.parent(ccall)ans$call <- ocallans}## FIXME: need settings for wireframe line colors (wires), cloud## points/cross lines (cloud.3d),cloud <- function(x, data, ...) UseMethod("cloud")## FIXME: made xlim/ylim similar to levelplot.matrix? What about## cloud.table?cloud.matrix <-function(x, data = NULL, type = 'h',zlab = deparse(substitute(x)),aspect,..., xlim, ylim,row.values = seq_len(nrow(x)),column.values = seq_len(ncol(x))){stopifnot(length(row.values) == nrow(x),length(column.values) == ncol(x))if (!is.null(data)) warning("explicit 'data' specification ignored")form <- eval(z ~ row * column)if (missing(aspect)) aspect <- pmin(ncol(x) / nrow(x), c(Inf, 1))data <-expand.grid(row = seq_len(nrow(x)),column = seq_len(ncol(x)))data$z <- as.vector(as.numeric(x))## if rownames/colnames are non-null, use them to labelif (missing(xlim))xlim <-if (!is.null(rownames(x))) rownames(x)else range(row.values, finite = TRUE)if (missing(ylim))ylim <-if (!is.null(colnames(x))) colnames(x)else range(column.values, finite = TRUE)cloud(form, data, type = type, zlab = zlab, aspect = aspect,xlim = xlim, ylim = ylim,...)}cloud.table <-function(x, data = NULL, groups = FALSE,zlab = deparse(substitute(x)),type = "h", ...){stopifnot(length(dim(x)) > 1)data <- as.data.frame(x)nms <- names(data)freq <- which(nms == "Freq")nms <- nms[-freq]form <- sprintf("Freq ~ %s * %s", nms[1], nms[2])nms <- nms[-c(1, 2)]len <- length(nms)if (is.logical(groups) && groups && len > 0){groups <- as.name(nms[len])nms <- nms[-len]len <- length(nms)}else groups <- NULLif (len > 0){rest <- paste(nms, collapse = "+")form <- paste(form, rest, sep = "|")}cloud(as.formula(form), data,groups = eval(groups),zlab = zlab,type = type, ...,default.scales =list(x = list(arrows = FALSE),y = list(arrows = FALSE)))}cloud.formula <-function(x,data = NULL,allow.multiple = is.null(groups) || outer,outer = FALSE,auto.key = FALSE,aspect = c(1,1),panel.aspect = 1,panel = lattice.getOption("panel.cloud"),prepanel = NULL,scales = list(),strip = TRUE,groups = NULL,xlab,ylab,zlab,xlim = if (is.factor(x)) levels(x) else range(x, finite = TRUE),ylim = if (is.factor(y)) levels(y) else range(y, finite = TRUE),zlim = if (is.factor(z)) levels(z) else range(z, finite = TRUE),at,drape = FALSE,pretty = FALSE,drop.unused.levels = lattice.getOption("drop.unused.levels"),...,lattice.options = NULL,default.scales = list(distance = c(1, 1, 1), arrows = TRUE, axs = axs.default),colorkey = any(drape),col.regions,alpha.regions,cuts = 70,subset = TRUE,axs.default = "r")## the axs.default is to (by default) enable scale extension for## cloud, but not for wireframe. Needs work to be actually## implemented.{stopifnot(is.numeric(panel.aspect))formula <- xdots <- list(...)groups <- eval(substitute(groups), data, environment(formula))subset <- eval(substitute(subset), data, environment(formula))if (!is.null(lattice.options)){oopt <- lattice.options(lattice.options)on.exit(lattice.options(oopt), add = TRUE)}## Step 1: Evaluate x, y, z etc. and do some preprocessingform <-latticeParseFormula(formula, data, dimension = 3,subset = subset, groups = groups,multiple = allow.multiple,outer = outer, subscripts = TRUE,drop = drop.unused.levels)## We need to be careful with subscripts here. It HAS to be there,## and it's to be used to index x, y, z (and not only groups,## unlike in xyplot etc). This means we have to subset groups as## well, which is about the only use for the subscripts calculated## in latticeParseFormula, after which subscripts is regenerated## as a straight sequence indexing the variablesif (!is.null(form$groups))groups <-if (is.matrix(form$groups)) as.vector(form$groups)[form$subscr]else if (is.data.frame(form$groups))as.vector(as.matrix(form$groups))[form$subscr]else form$groups[form$subscr]subscr <- seq_len(length(form$left))if (!is.function(panel)) panel <- eval(panel)if (!is.function(strip)) strip <- eval(strip)prepanel <-if (is.function(prepanel)) prepanelelse if (is.character(prepanel)) get(prepanel)else eval(prepanel)cond <- form$conditionz <- form$leftx <- form$right.xy <- form$right.y## (2004-03-12) experimental stuff: when x, y, z are all matrices## of the same dimension, they represent a 3-D surface## parametrized on a 2-D grid (the details of the parametrizing## grid are unimportant). This is meant only for wireframeisParametrizedSurface <-is.matrix(x) && is.matrix(y) && is.matrix(z)if (length(cond) == 0){strip <- FALSEcond <- list(gl(1, length(x)))}if (missing(xlab)) xlab <- form$right.x.nameif (missing(ylab)) ylab <- form$right.y.nameif (missing(zlab)) zlab <- form$left.namezrng <-if (isParametrizedSurface)extend.limits(sqrt(range(x^2 + y^2 + z^2, finite = TRUE)))elseextend.limits(range(as.numeric(z), finite = TRUE))if (missing(at))at <-if (drape){if (pretty) pretty(zrng, cuts)else seq(zrng[1], zrng[2], length.out = cuts+2)}else zrng## create a skeleton trellis object with the## less complicated components:foo <-do.call("trellis.skeleton",c(list(formula = formula,cond = cond,aspect = panel.aspect,strip = strip,panel = panel,xlab = NULL,ylab = NULL,lattice.options = lattice.options), dots))##----------------------------------------------------------------+## xlab, ylab, zlab have special meaning in cloud / wireframe, and|## need to be passed to the panel function to be processed. These |## xlab / ylab are dummies to satisfy the usual processing |## routines ------------------------------------------------------+dots <- foo$dots # arguments not processed by trellis.skeletonfoo <- foo$foofoo$call <- sys.call(sys.parent()); foo$call[[1]] <- quote(cloud)## Step 2: Compute scales.common (leaving out limits for now)foo <- c(foo, do.call("construct.scales", list(draw=FALSE)))## scales has to be interpreted differently. Nothing needs to be## done for the usual scales, but need a scales for panel.cloud## S-PLUS probably doesn't allow x-y-z-specific scales, but I see## no reason not to allow that (will not allow limits, though)scales <- updateList(default.scales, scales)scales.3d <- do.call("construct.3d.scales", scales)## Step 3: Decide if limits were specified in call## Here, always FALSE (in the 2d panel sense)have.xlim <- FALSEhave.ylim <- FALSE## Step 4: Decide if log scales are being used: !!!have.xlog <- !is.logical(scales.3d$x.scales$log) || scales.3d$x.scales$loghave.ylog <- !is.logical(scales.3d$y.scales$log) || scales.3d$y.scales$loghave.zlog <- !is.logical(scales.3d$z.scales$log) || scales.3d$z.scales$logif (have.xlog){xlog <- scales.3d$x.scales$logxbase <-if (is.logical(xlog)) 10else if (is.numeric(xlog)) xlogelse if (xlog == "e") exp(1)x <- log(x, xbase)if (!missing(xlim)) xlim <- logLimits(xlim, xbase)}if (have.ylog){ylog <- scales.3d$y.scales$logybase <-if (is.logical(ylog)) 10else if (is.numeric(ylog)) ylogelse if (ylog == "e") exp(1)y <- log(y, ybase)if (!missing(ylim)) ylim <- logLimits(ylim, ybase)}if (have.zlog){zlog <- scales.3d$z.scales$logzbase <-if (is.logical(zlog)) 10else if (is.numeric(zlog)) zlogelse if (zlog == "e") exp(1)z <- log(z, zbase)if (!missing(zlim)) zlim <- logLimits(zlim, zbase)}## Step 5: Process condcond.max.level <- unlist(lapply(cond, nlevels))if (is.logical(colorkey)){if (colorkey){colorkey <- list(at = at, space = "right")if (!missing(col.regions)) colorkey$col <- col.regionsif (!missing(alpha.regions)) colorkey$alpha <- alpha.regions}else colorkey <- NULL}else if (is.list(colorkey)){tmp <- ## FIXME: does the inside thing work? probably notlist(space = if (any(c("x", "y", "corner") %in% names(colorkey))) "inside" else "right",at = at)if (!missing(col.regions)) tmp$col <- col.regionsif (!missing(alpha.regions)) tmp$alpha <- alpha.regionscolorkey <- updateList(tmp, colorkey)}foo$legend <-construct.legend(foo$legend,colorkey,fun = "draw.colorkey")##################################### if (!drape) col.regions <- trellis.par.get("background")$col# ## region# numcol <- length(at) - 1# numcol.r <- length(col.regions)# col.regions <-# if (numcol.r <= numcol)# rep(col.regions, length.out = numcol)# else col.regions[floor(1+(1:numcol-1)*(numcol.r-1)/(numcol-1))]# if (is.logical(colorkey))# {# if (colorkey) colorkey <-# list(space = "right", col = col.regions,# at = at, tick.number = 7)# else colorkey <- NULL# }# else if (is.list(colorkey))# {# ##foo$colorkey <- colorkey# if (is.null(colorkey$col)) colorkey$col <- col.regions# if (is.null(colorkey$at)) colorkey$at <- at# if (is.null(colorkey$space)) colorkey$space <-# if (any(c("x", "y", "corner") %in% names(colorkey))) "inside" else "right"# }# foo$legend <-# construct.legend(foo$legend,# colorkey,# fun = "draw.colorkey")################################### maybe *lim = NULL with relation = "free" ?## Process limits here ? Needs some thought## Step 6: Determine packetsfoo$panel.args.common <-c(list(x = x, y = y, z = z,## rot.mat = rot.mat,## zoom = zoom,xlim = xlim, ylim = ylim, zlim = zlim,xlab = xlab, ylab = ylab, zlab = zlab,xlab.default = form$right.x.name,ylab.default = form$right.y.name,zlab.default = form$left.name,##distance = if (perspective) distance else 0,aspect = aspect,panel.aspect = panel.aspect,drape = drape,scales.3d = scales.3d,at = at),dots)if (!missing(col.regions)) foo$panel.args.common$col.regions <- col.regionsif (!missing(alpha.regions)) foo$panel.args.common$alpha.regions <- alpha.regionsif (!is.null(groups)) foo$panel.args.common$groups <- groupsnpackets <- prod(cond.max.level)if (npackets != prod(sapply(foo$condlevels, length)))stop("mismatch in number of packets")foo$panel.args <- vector(mode = "list", length = npackets)foo$packet.sizes <- numeric(npackets)if (npackets > 1){dim(foo$packet.sizes) <- sapply(foo$condlevels, length)dimnames(foo$packet.sizes) <- lapply(foo$condlevels, as.character)}cond.current.level <- rep(1, length(cond))for (packet.number in seq_len(npackets)){id <- compute.packet(cond, cond.current.level)foo$packet.sizes[packet.number] <- sum(id)foo$panel.args[[packet.number]] <-list(subscripts = subscr[id])cond.current.level <-cupdate(cond.current.level,cond.max.level)}more.comp <-c(limits.and.aspect(prepanel.default.cloud,prepanel = prepanel,have.xlim = have.xlim, xlim = xlim,have.ylim = have.ylim, ylim = ylim,x.relation = foo$x.scales$relation,y.relation = foo$y.scales$relation,panel.args.common = foo$panel.args.common,panel.args = foo$panel.args,aspect = panel.aspect,npackets = npackets),cond.orders(foo))foo[names(more.comp)] <- more.compif (is.null(foo$legend) && !is.null(groups) &&(is.list(auto.key) || (is.logical(auto.key) && auto.key))){foo$legend <-list(list(fun = "drawSimpleKey",args =updateList(list(text = levels(as.factor(groups)),points = TRUE,rectangles = FALSE,lines = FALSE),if (is.list(auto.key)) auto.key else list())))foo$legend[[1]]$x <- foo$legend[[1]]$args$xfoo$legend[[1]]$y <- foo$legend[[1]]$args$yfoo$legend[[1]]$corner <- foo$legend[[1]]$args$cornernames(foo$legend) <-if (any(c("x", "y", "corner") %in% names(foo$legend[[1]]$args)))"inside"else"top"if (!is.null(foo$legend[[1]]$args$space))names(foo$legend) <- foo$legend[[1]]$args$space}class(foo) <- "trellis"foo}