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.
Many Thanks
Rishabh
THE SCRIPT:
s3d <- scatterplot3d(x, y, z, type="n", xlab="x", ylab="y", zlab="z")
for (g in unique(G))
{
bxp.stx <- boxplot.stats(x[G==levels(G)[g]])
bxp.sty <- boxplot.stats(y[G==levels(G)[g]])
bxp.stz <- boxplot.stats(z[G==levels(G)[g]])
lines(s3d$xyz.convert(bxp.stx$stats[c(3, 3)], bxp.sty$stats[c(3, 3)], bxp.stz$stats[c(1, 5)]))
lines(s3d$xyz.convert(bxp.stx$stats[c(3, 3)], bxp.sty$stats[c(1, 5)], bxp.stz$stats[c(3, 3)]))
lines(s3d$xyz.convert(bxp.stx$stats[c(1, 5)], bxp.sty$stats[c(3, 3)], bxp.stz$stats[c(3, 3)]))
lines(s3d$xyz.convert(bxp.stx$stats[c(3, 3)], bxp.sty$stats[c(3, 3)], bxp.stz$stats[c(2, 4)]), lwd = 3)
lines(s3d$xyz.convert(bxp.stx$stats[c(3, 3)], bxp.sty$stats[c(2, 4)], bxp.stz$stats[c(3, 3)]), lwd = 3)
lines(s3d$xyz.convert(bxp.stx$stats[c(2, 4)], bxp.sty$stats[c(3, 3)], bxp.stz$stats[c(3, 3)]), lwd = 3)
s3d$points3d(bxp.stx$stats[3], bxp.sty$stats[3], bxp.stz$stats[3], pch = 18, col = "red")
}
Where,
x, y, z are the list of values along each axis
G is the Group variable
-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
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
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._
question about cloud() in lattice package
3 messages · Deepayan Sarkar, Rishabh Gupta
1 day later
--- 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
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._
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
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._