[R] question about cloud() in lattice package
Deepayan Sarkar
deepayansarkar at yahoo.com
Wed Aug 14 08:07:48 CEST 2002
--- 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
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._
More information about the R-help
mailing list