[R] question about cloud() in lattice package
Rishabh Gupta
rg117 at ohm.york.ac.uk
Wed Aug 14 16:53:58 CEST 2002
Hi
Thanks very much for your reply. I'm afraid I can't really claim to understand the workings of the function that you have
written since I am not that familiar with the lattice library (or R for that matter) but I tried it out and it works perfectly. Your
help is really appreciated.
Many Thanks
Rishabh
----- Original Message -----
From: "Deepayan Sarkar" <deepayansarkar at yahoo.com>
To: "Rishabh Gupta" <rg117 at ohm.york.ac.uk>; <r-help at stat.math.ethz.ch>
Sent: Wednesday, August 14, 2002 7:07 AM
Subject: Re: [R] question about cloud() in lattice package
|
| --- Rishabh Gupta <rg117 at ohm.york.ac.uk> wrote:
| > Hi all,
| > I have been previously been using scatterplot3d package to create some graphs
| > but unfortunately it does not allow me to rotate the
| > plot on all three axis. The cloud() function in the lattice package does
| > allow me to do so. When I was using scatterplot3d I was
| > using a script (Shown Below) to calculate the mean, quartiles and range
| > limits for all three axis and I was representing that on the
| > plot (like a 3d version of the boxplot() function). I was just wondering
| > whether there is any way of representing such information
| > with the cloud() function. Is there a way I can draw lines along each axis on
| > the plot.
| > Any help would be greatly appreciated.
|
|
| You could try using the (horrible) panel function given below. It's a
| modification of panel.cloud. The actual modifications shouldn't be difficult to
| follow, and are demarcated as "New", in case you want to change colors etc.
|
| An example of usage :
|
| data(iris)
| cloud(Sepal.Length ~ Petal.Width * Petal.Length, data = iris,
| groups = Species,
| panel = "panel.cloudbox",
| zoom = .8)
|
| #########################
|
| panel.cloudbox <- function (x, y, z, subscripts, distance, xlim,
| ylim, zlim, subpanel = "panel.xyplot", rot.mat = rot.mat, aspect =
| aspect, zcol, col.regions, par.box = NULL, xlab, ylab, zlab,
| scales.3d, proportion = 0.6, wireframe = FALSE, scpos = list(x =
| 1, y = 8, z = 12), groups, ...)
|
| {
| if (any(subscripts)) {
| par.box.final <- trellis.par.get("box.3d")
| if (!is.null(par.box))
| par.box.final[names(par.box)] <- par.box
| subpanel <- if (is.character(subpanel))
| get(subpanel)
| else eval(subpanel)
| aspect <- rep(aspect, length = 2)
| x <- x[subscripts]
| y <- y[subscripts]
| z <- z[subscripts]
|
| corners <- data.frame(x = c(-1, 1, 1, -1, -1, 1, 1, -1)/2,
| y = c(-1, -1, -1, -1, 1, 1, 1, 1)/2 * aspect[1],
| z = c(-1, -1, 1, 1, -1, -1, 1, 1)/2 * aspect[2])
| 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)
| labs <- 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)
| x.at <- if (is.logical(scales.3d$x.scales$at))
| lpretty(xlim, scales.3d$x.scales$tick.number)
| else scales.3d$x.scales$at
| y.at <- if (is.logical(scales.3d$y.scales$at))
| lpretty(ylim, scales.3d$y.scales$tick.number)
| else scales.3d$y.scales$at
| z.at <- if (is.logical(scales.3d$z.scales$at))
| lpretty(zlim, scales.3d$z.scales$tick.number)
| else scales.3d$z.scales$at
| x.at <- x.at[x.at >= xlim[1] & x.at <= xlim[2]]
| y.at <- y.at[y.at >= ylim[1] & y.at <= ylim[2]]
| z.at <- z.at[z.at >= zlim[1] & z.at <= zlim[2]]
| x.at.lab <- if (is.logical(scales.3d$x.scales$labels))
| as.character(x.at)
| else as.character(scales.3d$x.scales$labels)
| y.at.lab <- if (is.logical(scales.3d$y.scales$labels))
| as.character(y.at)
| else as.character(scales.3d$y.scales$labels)
| z.at.lab <- if (is.logical(scales.3d$z.scales$labels))
| as.character(z.at)
| else as.character(scales.3d$z.scales$labels)
| cmin <- lapply(corners, min)
| cmax <- lapply(corners, max)
| clen <- lapply(corners, function(x) diff(range(x)))
|
| #######################################################
| ## New ##
| #######################################################
|
| bxp.stx <- numeric(0)
| bxp.sty <- numeric(0)
| bxp.stz <- numeric(0)
|
| vals <- sort(unique(groups))
| for (i in seq(along=vals)) {
| id <- (groups[subscripts] == vals[i])
| foox <- boxplot.stats(x[id])$stats
| fooy <- boxplot.stats(y[id])$stats
| fooz <- boxplot.stats(z[id])$stats
| bxp.stx <- c(bxp.stx, foox, rep(foox[3], 5), rep(foox[3], 5))
| bxp.sty <- c(bxp.sty, rep(fooy[3], 5), fooy, rep(fooy[3], 5))
| bxp.stz <- c(bxp.stz, rep(fooz[3], 5), rep(fooz[3], 5), fooz)
| }
|
| tdata <- rbind(x = cmin$x + clen$x * (bxp.stx - xlim[1])/diff(xlim),
| y = cmin$y + clen$y * (bxp.sty - ylim[1])/diff(ylim),
| z = cmin$z + clen$z * (bxp.stz - zlim[1])/diff(zlim))
|
| #######################################################
|
| taxes <- rot.mat %*% axes
| 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 * 0.05 * labs[,1]
| y.at.end <- y.at + scales.3d$y.scales$tck * 0.05 * labs[,
| 2]
| z.at.end <- z.at + scales.3d$z.scales$tck * 0.05 * labs[,
| 3]
| x.labs <- x.at + 2 * scales.3d$x.scales$tck * 0.05 *
| labs[, 1]
| y.labs <- y.at + 2 * scales.3d$y.scales$tck * 0.05 *
| labs[, 2]
| z.labs <- z.at + 2 * scales.3d$z.scales$tck * 0.05 *
| labs[, 3]
| x.at <- rot.mat %*% x.at
| x.labs <- rot.mat %*% x.labs
| x.at.end <- rot.mat %*% x.at.end
| y.at <- rot.mat %*% y.at
| y.labs <- rot.mat %*% y.labs
| y.at.end <- rot.mat %*% y.at.end
| z.at <- rot.mat %*% z.at
| z.labs <- rot.mat %*% z.labs
| z.at.end <- rot.mat %*% z.at.end
| tdata <- rot.mat %*% tdata
| corners <- rot.mat %*% t(as.matrix(corners))
| tlabs <- rot.mat %*% labs
| zback <- min(corners[3, ])
| zfront <- max(corners[3, ])
| za <- (zfront * (1 - distance) - zback)/(zfront - zback)
| zb <- distance/(zfront - zback)
| tdata[1, ] <- (za + zb * tdata[3, ]) * tdata[1, ]
| tdata[2, ] <- (za + zb * tdata[3, ]) * tdata[2, ]
| corners[1, ] <- (za + zb * corners[3, ]) * corners[1,
| ]
| corners[2, ] <- (za + zb * corners[3, ]) * corners[2,
| ]
| taxes[1, ] <- (za + zb * taxes[3, ]) * taxes[1, ]
| taxes[2, ] <- (za + zb * taxes[3, ]) * taxes[2, ]
| x.at[1, ] <- (za + zb * x.at[3, ]) * x.at[1, ]
| x.at[2, ] <- (za + zb * x.at[3, ]) * x.at[2, ]
| x.labs[1, ] <- (za + zb * x.labs[3, ]) * x.labs[1, ]
| x.labs[2, ] <- (za + zb * x.labs[3, ]) * x.labs[2, ]
| x.at.end[1, ] <- (za + zb * x.at.end[3, ]) * x.at.end[1,
| ]
| x.at.end[2, ] <- (za + zb * x.at.end[3, ]) * x.at.end[2,
| ]
| y.at[1, ] <- (za + zb * y.at[3, ]) * y.at[1, ]
| y.at[2, ] <- (za + zb * y.at[3, ]) * y.at[2, ]
| y.labs[1, ] <- (za + zb * y.labs[3, ]) * y.labs[1, ]
| y.labs[2, ] <- (za + zb * y.labs[3, ]) * y.labs[2, ]
| y.at.end[1, ] <- (za + zb * y.at.end[3, ]) * y.at.end[1,
| ]
| y.at.end[2, ] <- (za + zb * y.at.end[3, ]) * y.at.end[2,
| ]
| z.at[1, ] <- (za + zb * z.at[3, ]) * z.at[1, ]
| z.at[2, ] <- (za + zb * z.at[3, ]) * z.at[2, ]
| z.labs[1, ] <- (za + zb * z.labs[3, ]) * z.labs[1, ]
| z.labs[2, ] <- (za + zb * z.labs[3, ]) * z.labs[2, ]
| z.at.end[1, ] <- (za + zb * z.at.end[3, ]) * z.at.end[1,
| ]
| z.at.end[2, ] <- (za + zb * z.at.end[3, ]) * z.at.end[2,
| ]
| tlabs[1, ] <- (za + zb * tlabs[3, ]) * tlabs[1, ]
| tlabs[2, ] <- (za + zb * tlabs[3, ]) * tlabs[2, ]
| farthest <- 1
| farval <- corners[3, 1]
| for (i in 2:8) if (corners[3, i] < farval) {
| farthest <- i
| farval <- corners[3, i]
| }
| mark <- rep(TRUE, 12)
| for (j in 1:12) if (pre[j] == farthest || nxt[j] == farthest)
| mark[j] <- FALSE
| lsegments(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)
|
| #############################################
| ## New ##
| #############################################
|
| for (i in seq(along=vals)) {
| llines(x = tdata[1, 15 * (i-1) + c(1,5)],
| y = tdata[2, 15 * (i-1) + c(1,5)])
| llines(x = tdata[1, 15 * (i-1) + c(6,10)],
| y = tdata[2, 15 * (i-1) + c(6,10)])
| llines(x = tdata[1, 15 * (i-1) + c(11,15)],
| y = tdata[2, 15 * (i-1) + c(11,15)])
|
| llines(x = tdata[1, 15 * (i-1) + c(2,4)],
| y = tdata[2, 15 * (i-1) + c(2,4)], lwd = 3)
| llines(x = tdata[1, 15 * (i-1) + c(7,9)],
| y = tdata[2, 15 * (i-1) + c(7,9)], lwd = 3)
| llines(x = tdata[1, 15 * (i-1) + c(12,14)],
| y = tdata[2, 15 * (i-1) + c(12,14)], lwd = 3)
|
| lpoints(x = tdata[1, 15 * (i-1) + 3],
| y = tdata[2, 15 * (i-1) + 3],
| col = "red", pch = 18)
| }
|
|
| #############################################
|
| lsegments(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)
| if (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], lty = scales.3d$x.scales$lty,
| lwd = scales.3d$x.scales$lwd,
| col = scales.3d$x.scales$col)
| }
| else {
| lsegments(x0 = x.at[1, ], y0 = x.at[2, ],
| x1 = x.at.end[1,
| ], y1 = x.at.end[2, ], lty = scales.3d$x.scales$lty,
| col = scales.3d$x.scales$col,
| lwd = scales.3d$x.scales$lwd)
| ltext(x.at.lab, x = x.labs[1, ],
| y = x.labs[2,
| ], cex = scales.3d$x.scales$cex,
| font = scales.3d$x.scales$font,
| col = scales.3d$x.scales$col)
| }
| }
| 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], lty = scales.3d$y.scales$lty,
| lwd = scales.3d$y.scales$lwd,
| col = scales.3d$y.scales$col)
| }
| else {
| lsegments(x0 = y.at[1, ], y0 = y.at[2, ],
| x1 = y.at.end[1,
| ], y1 = y.at.end[2, ], lty = scales.3d$y.scales$lty,
| col = scales.3d$y.scales$col,
| lwd = scales.3d$y.scales$lwd)
| ltext(y.at.lab, x = y.labs[1, ],
| y = y.labs[2,
| ], cex = scales.3d$y.scales$cex,
| font = scales.3d$y.scales$font,
| col = scales.3d$y.scales$col)
| }
| }
| 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], lty = scales.3d$z.scales$lty,
| lwd = scales.3d$z.scales$lwd,
| col = scales.3d$z.scales$col)
| }
| else {
| lsegments(x0 = z.at[1, ], y0 = z.at[2, ],
| x1 = z.at.end[1,
| ], y1 = z.at.end[2, ], lty = scales.3d$z.scales$lty,
| col = scales.3d$x.scales$col,
| lwd = scales.3d$z.scales$lwd)
| ltext(z.at.lab, x = z.labs[1, ],
| y = z.labs[2,
| ], cex = scales.3d$z.scales$cex,
| font = scales.3d$z.scales$font,
| col = scales.3d$z.scales$col)
| }
| }
| if (!is.null(xlab))
| ltext(xlab$lab, x = tlabs[1, 1], y = tlabs[2, 1],
| cex = xlab$cex, rot = xlab$rot, font = xlab$font,
| col = xlab$col)
| if (!is.null(ylab))
| ltext(ylab$lab, x = tlabs[1, 2], y = tlabs[2, 2],
| cex = ylab$cex, rot = ylab$rot, font = ylab$font,
| col = ylab$col)
| if (!is.null(zlab))
| ltext(zlab$lab, x = tlabs[1, 3], y = tlabs[2, 3],
| cex = zlab$cex, rot = zlab$rot, font = zlab$font,
| col = zlab$col)
| }
| }
|
|
|
|
|
| __________________________________________________
|
|
|
| -.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
| r-help mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
| Send "info", "help", or "[un]subscribe"
| (in the "body", not the subject !) To: r-help-request at stat.math.ethz.ch
| _._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._
|
-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
r-help mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
Send "info", "help", or "[un]subscribe"
(in the "body", not the subject !) To: r-help-request at stat.math.ethz.ch
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._
More information about the R-help
mailing list